*DECK,    SCANNER 
          IDENT     SCANNER 
          TITLE  SCANNER
*CALL     SSTCALL 
          LIST   F,X
 B=SCANR  RPVDEF             DEFINE ROUTINE FWA FOR REPRIEVE UTILITY
 AUXT     SPACE  4,8
**        AUXT - GENERATE AUXILIARY KEYWORD TABLE.
* 
*                GENERATES THE FIRST LETTER INDEX TABLE. THIS MACRO 
*         IS CALLED ONLY FROM *KEYW* MACRO. 
* 
*         AUXT   STRING 
* 
*         ENTRY  *STRING*  = THE FORTRAN KEYWORD. 
* 
*         USES   NONE 
* 
*         CALLS  NONE 
  
 AUXT     MACRO  STRING 
 .F       MICRO  1,1,/STRING/ 
          IFC    GT,/".F"/".L"/,7 
 KW.".F"  BSS    0
          IF     DEF,KW.".L",4
          USE    SRCHA
          VFD    30/KW.".L",30/KW.".F"
          BSSZ   1R".F"-1R".L"-1
          USE    *
 .L       MICRO  1,,/".F"/
 AUXT     ENDM
 ELPUT    SPACE  4,8
**        ELPUT - ENTER WORD IN E-LIST. 
* 
*         ELPUT  WORD 
* 
* 
*         ENTRY  *WORD* = X-REGISTER CONTAINING WORD FOR E-LIST, OR 
*                         ADDRESS EXPRESSION FOR LOCATION OF WORD.
*                         SEE *XR=* MACRO IN *FTNTEXT* FOR VALID FORMS. 
* 
*         USES   X1, A1 
* 
*         CALLS  AWE
  
  
          PURGMAC  ELPUT
  
 ELPUT    MACRO  W
          XR=    X1,W 
          RJ     AWE
 ELPUT    ENDM
 JPC      SPACE  4,8
**        JPC - JUMP ON CHARACTER.
* 
*                MAKE AN ENTRY IN THE *LEX-N-* CHARACTER JUMP TABLE.
* 
*         JPC    ADDR,ELIST 
* 
*         ENTRY  *ADDR*   =  THE ADDRESS TO WHICH CONTROL IS TO BE
*                            TRANSFERRED FOR THIS CHARACTER UPON ENTRY
*                            INTO THIS *LEX-N-* ROUTINE.
* 
*                *ELIST*  =  IF PRESENT, THE ADDRESS OF AN *ELIST*
*                            ELEMENT SKELETON FOR THIS CHARACTER. 
* 
*         EXIT   NO CONDITIONS
* 
*         USES   NONE 
* 
*         CALLS  NONE 
  
 JPC      MACRO  ADDR,ELIST 
          VFD    12/0,18/ELIST,12/0,18/ADDR 
 JPC      ENDM
 KEYW     SPACE  4,8
**        KEYW - GENERATE KEYWORD TABLES. 
* 
*                GENERATES THE VARIOUS TABLES ASSOCIATED WITH KEYWORD 
*         PROCESSING. 
* 
*  SUCC   KEYW   STRING,TYPE,ATYPE,CALLERS,ANSI 
* 
*         ENTRY  *SUCC*    = SUCCESS EXIT JUMP ADDRESS. IF A FIND IS
*                            MADE ON THIS KEYWORD STRING, CONTROL 
*                            IS TRANSFERRED TO THE LABEL *SRCH_SUCC*. 
*                            DEFAULT IS *SRCH*. 
*                *STRING*  = THE FORTRAN KEYWORD. 
*                *TYPE*    = STATEMENT TYPE CODE FOR THIS KEYWORD.
*                *ATYPE*   = AUXILIARY STATEMENT TYPE CODE FOR THIS 
*                            KEYWORD. DEFAULT IS -0.
*                *CALLERS* = WHERE *CALLERS* IS A LIST OF LEGAL *SRCH*
*                            CALLERS, (CLR1,CLR2,...,CLRN). THIS LIST 
*                            SPECIFIES THAT IT IS ONLY SYNTACTICALLY
*                            CORRECT TO FIND THIS KEYWORD FROM THE
*                            *SRCH* CALLER AT THE LABELS *LEX_CLR1, 
*                            LEX_CLR2,...,LEX_CLRN*.
*                *ANSI*    = IF NON-BLANK, SPECIFIES THAT THIS IS A 
*                            NON-ANSI KEYWORD.
* 
*         USES   NONE 
* 
*         CALLS  NONE 
* 
          NOREF  .1,.2
 .L       MICRO 
  
  
          MACRO  KEYW,SUCC,STRING,TYPE,ATYPE,CALLERS,ANSI 
* 
*         GENERATE 1ST LETTER INDEX TABLE.
* 
          AUXT   STRING 
* 
*         GENERATE KEYWORD TABLE. 
* 
 .1       MICRO  1,,/STRING/
 .1       MICCNT .1 
 .2       SET    ATYPE 17B
          VFD    12/1777B+6*.1,18/SRCH_SUCC,4/.2,8/TYPE,18/=0L_STRING 
* 
*         SET BITS IN LEGAL CALLER TYPE SHIFT TABLE.
* 
 #CL      IRP    CALLERS
          USE    CLR_CALLERS
          POS    1
          POS    60-TYPE
          VFD    1/1
          USE    *
 #CL      IRP 
* 
*         GENERATE NON-ANSI KEYWORD SHIFT WORD. 
* 
          IFC    NE,/ANSI//,5 
          USE    NANSI
          POS    1
          POS    60-TYPE
          VFD    1/1
          USE    *
* 
 KEYW     ENDM
 SRCH     SPACE  4,8
**        SRCH - TRY TO TYPE THE STATEMENT. 
* 
*                TASKS PERFORMED -- 
*         1.     CALLS *SRCH* TO SEARCH THE INITIAL STRING FOR A
*                MATCH OF THE LEADING KEYWORD.
*         2.     SETS UP THE CORRECT *USE* BLOCKS AND DEFINES THE 
*                LEGAL TYPE SHIFT WORD ASSOCIATED WITH DETERMINING
*                WHETHER A KEYWORD IS SYNTACTICALLY LEGAL FROM THIS 
*                *SRCH* CALLER. 
* 
* LAB     SRCH   ERTN 
* 
*         ENTRY  *LAB*   =   A *LEX* LABEL ASSOCIATED WITH THIS *SRCH*
*                            CALL. FOR EVERY KEYWORD THAT IS
*                            SYNTACTICALLY LEGAL FROM THIS CALLER,
*                            A *LAB* ENTRY SHOULD BE MADE IN THE
*                            *CALLERS* FIELD FOR THAT KEYWORD-S *KEYW*
*                            ENTRY. 
*                *ERTN*  =   ERROR RETURN OR THE NEXT *LEX-N-* ROUTINE
*                            IN THE LEXICAL SCANNING PROCESS. 
* 
*         EXIT   (B1)    =   NEXT *LEX-N-* ROUTINE. 
*                (X1)    =   LEGAL TYPE SHIFT WORD FOR THIS *SRCH*
*                            CALLER.
* 
*         USES   X - 1
*                A - 1
*                B - 1
* 
*         CALLS  SRCH 
  
          MACRO  SRCH,LAB,ERTN
          IFC    EQ,/LAB//,1
 P        ERR    *SRCH* REQUIRES A LABEL. 
 A        MICRO  4,,/LAB/ 
          USE    CLR_"A"
 LETS_"A" BSS    0
          USE    *
 LAB      SB1    ERTN        ERROR EXIT RETURN
          RJ     SRCH        TRY TO TYPE STMT 
          SA1    LETS_"A"    LEGAL TYPE SHIFT FOR THIS CALLER 
          NO
 SRCH     ENDM
 TYPER    SPACE  4,8
**        TYPER - DEFINE STATEMENT TYPER. 
* 
*  LAB    TYPER  ADDR 
* 
*         ENTRY  *LAB*  =  IF PRESENT, THE *LEX-N-* ROUTINE FOR WHICH 
*                          WE ARE DEFINING A STATEMENT TYPER. 
*                          *LAB*=*+1
* 
* 
*                *ADDR* =  THE ADDRESS OF THE STATEMENT TYPE DETERMINER 
*                          FOR THE *LEX-N-* ROUTINE AT *+1, NORMALLY
*                          *LAB*. IF A NEW STATEMENT IS FOUND BEFORE THE
*                          CURRENT STATEMENT HAS BEEN TYPED, *NEWS* WILL
*                          PICK UP *ADDR* FROM (B1)-1 AND THEN TRANSFER 
*                          CONTROL TO *ADDR* TO TRY AND TYPE THE
*                          STATEMENT. 
* 
*         EXIT   NO CONDITIONS
* 
*         USES   NONE 
* 
*         CALLS  NONE 
  
          MACRO  TYPER,LAB,ADDR 
          VFD    42/0,18/ADDR 
 LAB      BSS    0
 TYPER    ENDM
 ZERO     SPACE  4,8
**        ZERO - DEFINE A CELL TO BE IN *ZERO* BLOCK. 
* 
*                ALL CELLS THAT ARE DEFINED TO EXIST IN *ZERO* BLOCK
*         WILL BE SET TO ZERO EVERY TIME *SCANNER* IS ENTERED.
* 
* CELL    ZERO   NR,EPT 
* 
*         ENTRY  *CELL*  =   NAME OF CELL TO BE PLACED IN *ZERO* BLOCK. 
* 
*                *NR*    =   NR OF LOCATIONS TO BE RESERVED FOR *CELL*. 
* 
*                *EPT*   =   IF NON-BLANK, SPECIFIES THAT THIS CELL IS
*                              TO BE DECLARED AS AN ENTRY POINT.
* 
*         EXIT   NONE 
* 
*         USES   NONE 
* 
*         CALLS  NONE 
  
  
          PURGMAC ZERO
  
          MACRO  ZERO,CELL,NR,EPT 
          USE    ZERO 
 CELL     BSS    NR 
          USE    *
          IFC    NE,/EPT//,1
          ENTRY  CELL 
 ZERO     ENDM
          TITLE  EQU S AND LOWCORE CELLS
          SPACE  3
 CHAR     =      6           NR OF BITS IN CYBER CHARACTER
 SYMEND   EQU    13B               END OF SYMTAB
 L.STBZ   EQU    40D         LENGTH OF SAFETY BUFFER ZONE BETWEEN 
*                              FWA E-LIST AND LWA SYMTAB. 
 SELIST   EQU    32B
 TYPE     EQU    24B               STMT TYPE
 CLABEL   EQU    23B         CURRENT STATEMENT LABEL.  CONTENTS ARE 
                             (1) IF EMPTY OR ILLEGAL LABEL, .EQ. 0
                             (2) IF LEGAL NON-EMPTY LABEL, CONTAINS IT
                                  IN DISPLAY CODE, LEFT ADJ W/ BLNK FILL
 NLABEL   EQU    60B         NEXT STATEMENT LABEL. SEE 'CLABEL' DESCRIP 
 ATYPE    EQU    51B               ARITHMETIC STMT TYPE FOR TYPES 3 AND 
 LELIST   EQU    34B
 LTYPE    EQU    21B
 DUKE     EQU    37B               BINARY LINE COUNT
 SCNT     EQU    46B               LINE NUMBER FOR ERPRO
          SPACE  4,8
**        STATEMENT TYPE CODES. 
  
 ST.V=E   =      12          V=E (ASSIGNMENT) 
 ST.END   =      13          END (NORMAL) 
 ST.ASG   =      14          ASSIGN 
 ST.LIF   =      17          LOGICAL IF 
 ST.BAD   =      18          BAD STATEMENT
 ST.INV   =      37          END (INVENTED) 
          TITLE 
**        ERROR MESSAGE NUMBER DEFINITIONS. 
  
 E28      =      28          TABLES OVERLAP, INCREASE FIELD LENGTH
 E29      =      29          UNRECOGNIZED STATEMENT 
 E30      =      30          ILLEGAL LABEL
 E31      =      31          STATEMENT TOO LONG 
 E32      =      32          NAME TOO LONG
 E33      =      33          UNBALANCED PARENTHESES 
 E34      =      34          NON-ANSI 7-CHARACTER NAME
 E35      =      35          *END* MISSING, ASSUMED 
 E37      =      37          ILLEGAL CHARACTER
 E38      =      38          NON-ANSI *END* LINE FORMAT 
 E80      =      80          LABEL REFERENCE HAS MORE THAN 5 DIGITS 
 E104     =      104         INCOMPLETE HOLLERITH CONSTANT
 E111     =      111         ILLEGAL SYNTAX IN ASSIGN STATEMENT 
 E175     =      175         ILLEGAL STMT TYPE AFTER LOGICAL *IF* 
 E196     =      196         NON-ANSI LOGICAL OPERATOR
 E197     =      197         NON-ANSI OCTAL, R OR L CONSTANT
 E207     =      207         COMMENT LINE IN MIDDLE OF CONTIN LINES 
 E208     =      208         NON-ANSI BLANK LINE
 E209     =      209         LAST CHARACTER SEEN AFTER TROUBLE
 E210     =      210         NON-ANSI $ STATEMENT SEPARATOR 
 E325     =      325         SPURIOUS CHAR AFTER END IGNORED
 E221     =      221         NON-ANSI TYPE DECLARATION
 E228     =      228         NON-ANSI COMMENT LINE (COL 1 = $ OR *) 
 E259     =      259         NON-ANSI QUOTE-DELIMITED HOLLERITH STRING
 E289     =      289         *CONSTOR* OVERFLOW 
 E297     =      297         INVALID USE OF CHARACTER STRING
 E299     =      299         THIS STATEMENT IS A NON-ANSI STATEMENT 
 E313     =      313         ILLEGAL SYNTAX IN KEYWORD
 E319     =      319         C/-LIST DIRECTIVE MAY NOT BREAK CONT STRING
 E323     =      323         DEBUG CARD INSIDE CONTINUATION LINES IN DEBUG MODE 
 E324     =      324         UNRECOGNISED OPERATOR
 USES     SPACE  4,8
  
          USE    NANSI
 NANSI    BSS    0
          USE    *
  
          USE    SRCHA
 SRCHA    BSS    0           FIRST LETTER INDEX TABLE 
          USE    *
 O.VAR    ZERO   0           ORIGIN OF *ZERO* BLOCK 
          SPACE  3
          EXT    FWAWORK,LWAWORK
 ELAST    EQU    LWAWORK
          EXT    DFLAG
          ENTRY  FEFLAG 
  
*         BLANKS FOR BLANK FILL.
  
 FILLTEN  LIT    10R          ,9R         ,8R        ,7R       ,6R
,,5R     ,4R    ,3R   ,2R  ,1R ,0 
 FILL8R   =      FILLTEN+2
          SPACE  4,8
 ENDL     DATA   10H      END      CHARACTERS FOR INVENTED END LINE 
          VFD    6/64B,54/9HABSENT" 
 CONSTNTS SPACE  3,10 
*  SHIFT TEST MASKS FOR DISPLAY-CODED CHARACTER TESTS.
  
 COL1MASK BSS    0           ? SHIFT TEST MASK FOR <C>, <*> OR <$> IN 
          POS    60-1-1RC    ? COLUMN 1.  MASK IS RIGHT SHIFTED 1 BIT 
          VFD    1/1         ? AND 1 WILL BE ADDED TO THE DISPLAY CODED 
          POS    60-1-1R*    ? CHARACTER VALUE DURING THE ACTUAL TEST.
          VFD    1/1         ? THIS PREVENTS A <;>=63D FROM ALIASING AS 
          POS    60-1-1R$    ? <C>=03D DURING THE TEST, WHICH WOULD 
          VFD    1/1         ? OTHERWISE HAPPEN DUE TO THE MODULO 60
          POS    0           .... (NOT 64) NATURE OF A SHIFT MASK TEST. 
 MASKS    SPACE  1,6
 ZRBLMASK BSS    0           ? SHIFT TEST MASK FOR <0> OR < > 
          POS    60-1R0      ?
          VFD    1/1         ?
          POS    60-1R       ?
          VFD    1/1         ?
          POS    0           .... 
 CONSTNTS SPACE 1,8 
 HLRMASK  BSS    0           ?  SHIFT TEST MASK FOR <H> <L> <R> 
          POS    60-1RH      ?
          VFD    1/1         ?
          POS    60-1RL      ?
          VFD    1/1         ?
          POS    60-1RR      ?
          VFD    1/1         ?
          POS    0           .... 
 POINT    SPACE  4,8
*  POINT TABLE 1 - CONTROLS 'PTBL2' SEARCH START/STOP ADDRESSES, BASED
*  ON NUMBER OF CHARACTERS IN OPERATOR STRING.  TABLE ENTRY FORMAT IS-- 
* 
*         VFD    30/STOP ADDRESS,30/START ADDRESS 
* 
 PTBL1    VFD    30/PTBL2.5A,30/PTBL2.2A   *SPECIAL FOR 1-CHAR OPERATORS
          VFD    30/PTBL2.3,30/PTBL2.2
          VFD    30/PTBL2.4,30/PTBL2.3
          VFD    30/PTBL2.5,30/PTBL2.4
          VFD    30/PTBL2.5A,30/PTBL2.5 
          VFD    30/PTBLEND,30/PTBL2.5A 
  
*  POINT TABLE 2 - CONTAINS PICTURES OF ALL LEGAL OPERATORS, AND CORRES-
*  PONDING E-LIST ENTRY ELEMENT POINTER.  TABLE ENTRY FORMAT IS-- 
* 
*         VFD    36/H*PICTURE*,6/0,18/ADDR OF E-LIST ENTRY ELEMENT
* 
 PTBL2.2  VFD    36/2HEQ,6/0,18/EQ
          VFD    36/2HGE,6/0,18/GE
          VFD    36/2HGT,6/0,18/GT
          VFD    36/2HLE,6/0,18/LE
          VFD    36/2HLT,6/0,18/LT
          VFD    36/2HNE,6/0,18/NE
 PTBL2.2A VFD    36/2HOR,6/0,18/OR
 PTBL2.3  VFD    36/3HAND,6/0,18/AND
          VFD    36/3HNOT,6/0,18/NOT
 PTBL2.4  VFD    36/4HTRUE,6/0,18/TRUE
 PTBL2.5  VFD    36/5HFALSE,6/0,18/FALSE
 PTBL2.5A VFD    36/5HINDEF,6/0,18/INDEF
          VFD    36/5HRANGE,6/0,18/RANGE
          VFD    36/5HVALID,6/0,18/VALID
 PTBLEND  BSS    0
 ELIST    SPACE  4,8
*         *ELIST* ENTRY ELEMENTS. 
* 
  
 RP       VFD    12/2002B,48/0     )
 COMMA    VFD    12/2003B,48/0     ,
 EOS      VFD    12/2004B,48/0     END-OF-STMT
 EQU      VFD    12/2005B,48/0     =
 LP       VFD    12/2006B,48/0     (
 OR       VFD    12/2007B,48/2     .OR. 
 AND      VFD    12/2010B,48/3     .AND.
 NOT      VFD    12/2011B,48/4     .NOT.
 LE       VFD    12/2012B,48/5     .LE. 
 LT       VFD    12/2013B,48/5     .LT. 
 GE       VFD    12/2014B,48/5     .GE. 
 GT       VFD    12/2015B,48/5     .GT. 
 NE       VFD    12/2016B,48/5     .NE. 
 EQ       VFD    12/2017B,48/5     .EQ. 
 MINUS    VFD    12/2020B,48/6     -
 PLUS     VFD    12/2021B,48/6     +
 STAR     VFD    12/2022B,48/7     *
 SLASH    VFD    12/2023B,48/8     /
 DSTAR    VFD    12/2024B,48/10    ** 
 RANGE    VFD    12/2020B,48/5
 INDEF    VFD    12/2021B,48/5
 VALID    VFD    12/2022B,48/5
 TRUE     VFD    12/2000B,30/0,18/-1
 FALSE    VFD    12/2000B,48/0
          TITLE 
 BADLABL  BSSZ   1           =1 IF BAD LABEL IN NEW STMT, ELSE =0 
 BLNKSTMT ZERO   1           .NZ. WHEN BLANK SOURCE STATEMENT (INITIAL
*                              LINE AND CONTINUATION LINES) ENCOUNTERED 
*                            .ZR. WHEN NON-NULL LINE FOUND
 CAD      ZERO   1           CONSTANT PACK-IN-PROGRESS FLAG.  VALUES -- 
*                              .ZR. = NO CONSTANT PACK IN PROGRESS. 
*                              .PL. = PACKING NUMERIC CONSTANT. 
*                              .MI. = PACKING HOLLERITH CONSTANT. 
 CARDS    BSSZ   1           NR OF CARDS THAT HAVE BEEN READ IN THIS
*                              PROGRAM UNIT (SET BY /COMFRNC/).  THIS 
*                              CARD COUNT IS NOT USED BY THE OPTIMIZING 
*                              COMPILER, AND IS HERE ONLY FOR /COMFRNC/ 
*                              COMPATIBILITY (SEE *DUKE/DUKE1*).
 CCSTO    BSSZ   1           POINTER TO CURRENT 'CONSTOR' ENTRY 
 CD       ENTRY. 0
 COL      ENTRY. 0
 COLS     BSSZ   1           COLUMN POINTER, BIASED -7, SO 0 = COL 7
 COMMON   BSSZ   1           HOLDS E-LIST ENTRY 
 CONTCNT  BSSZ   1           CONTINUATION CARD COUNT
 CSSTMT   BSSZ   1           1S59 IF C/-LIST,ALL
*                             +1  IF C/-LIST,NONE 
*                             +0  IF NOT A C/-LIST LINE 
 CTYPE    BSSZ   1           TYPE OF CONSTANT 
 DUKE1    ENTRY. 0           SOURCE LINE COUNT (BINARY) 
 EXPEXP   ZERO   1           .NZ. WHEN EXPONENT EXPECTED, ELSE .ZR. 
 FTNCNT   BSSZ   1           SOURCE CARD LINE NUMBER IN DISPLAY CODE
 HANG.    ZERO   1           .NZ. UNTIL CHARACTER FOUND AFTER PERIOD
 IDENTOK  ENTRY. 0           =0 WHEN *IDENT* OK (NO FORTRAN YET), 
*                              = .NZ. WHEN ILLEGAL. 
 IEF      CON    1S59        INIT ENTRY FLAG = 1S59 WHEN DEFERRING
*                              SOURCE LISTING BEFORE HEADER LINE FOUND
*                              (OR 1. BEFORE 20 SOURCE LINES HAVE BEEN
*                              FOUND, OR 2. BEFORE A C/-LIST,NONE STMT
*                              IS FOUND, WHICHEVER OCCURS FIRST). 
*                              ELSE = 0 
 IMPFLG   ZERO   1           .NZ. WHEN PACKING *IMPLICIT* TYPE KEYWORD
  
 KEYL     BSSZ   6           KEYWORD LEN, 12/2000B+NR CHARS, 48/NR WORDS
 KEYW     =      KEYL+1      KEYWORD BUFFER 
  
 LCON     BSSZ   1           WORD FOR PACKING LABEL IN *ADJ*
 LOCC     BSSZ   1           STARTING ADDR OF CONSTANT IN 'CONSTOR' 
 L.CARD   BSSZ   1           NR OF WORDS IN SOURCE LINE IMAGE AT
*                              (CP.CARD) ET EQ  (INCLUDES FULL ZERO 
*                              WORD EOL MARK) 
 L.PLINE  BSSZ   1           NR OF WORDS IN PRINT LINE IMAGE AT 
*                              (CP.FLIN) ET SEQ.
*                              (L.PLINE) = 0 IF LINE ALREADY LISTED 
 N        BSSZ   1           LENGTH OF CONSTANT STRING
 NABC     BSSZ   1           NUMBER OF NON-ANSI BLANK LINES 
 NACOM    BSSZ   1           NUMBER OF NON-ANSI COMMENT LINES 
 NAFLG    ZERO   1           1S59 IF NON-ANSI TYPE DECLARATION OCCURRED 
 NOEND    BSSZ   1           =24D IF END CARD MISSING, ELSE =0
 NOLIST   ENTRY. 1S59        =1S59 IF C/-LIST, =0 IF C/-NOLIST ACTIVE 
 NULLSTMT ZERO   1           .ZR. UNTIL 1ST CHARACTER FOUND IN STATEMENT
 NXCOMENT BSSZ   1           .EQ. 1 FOR COMMENT CARD; ELSE .EQ. 0 
 N.EQUAL  ZERO   1,EPT       NUMBER OF EQUAL SIGNS IN STATEMENT 
 PAD      ZERO   1           .NZ. WHEN PACKING NAME (*PACK7* ACTIVE)
 PARENS   ZERO   1           PARENTHESIS COUNT
 REGS     BSSZ   7
 REG=B1   =      REGS 
 REG=B2   =      REGS+1 
 REG=B3   =      REGS+2 
 REG=B6   =      REGS+3 
 REG=X3   =      REGS+4 
 REG=X5   =      REGS+5 
 REG=X6   =      REGS+6 
 RELFLAG  ZERO   1           .NZ. IF RELATIONAL OR BOOLEAN OPR EXPECTED 
 SBUFLG   BSSZ   1           *SBUFF* STATUS FLAG.  VALUES --
*                              +0 = NEXT STMT NOT ALREADY IN *SBUFF*
*                              -1 = LAST STMT TERMINATED BY $ 
*                              +1 = LAST STMT TERMINATED BY BY NEXT STMT
          SPACE  4,8
          USE    ZERO 
 L.VAR    EQU    *-O.VAR     LENGTH OF VARIABLE BLOCK TO BE ZEROED
          USE    *
 CONSTOR  SPACE  4,8
          ENTRY  CONSTOR
 CONSTOR  BSSZ   CONSTORS 
 DLBUF    SPACE  4,8
**        DLBUF - DEFERRED LISTING BUFFER.
* 
*         SOURCE LINES, PREFIXED WITH DPC LINE NUMBERS, ARE SAVED HERE
*         FOR DEFERRED LISTING.  BUFFER SIZE IS ADEQUATE FOR A COMPLETE 
*         SOURCE STATEMENT OF 20 LINES, WITH 108 CHARACTERS PER LINE. 
  
 DLBUFL   =      20*13       DEFERRED LISTING BUFFER LENGTH 
 DLBUF    BSSZ   DLBUFL      DEFERRED LISTING BUFFER
 SBUFF    SPACE  4,8
          BSSZ   1           NEED THIS CELL TO INIT A6 IN 'READCARD'
 SBUFF    BSS    73-7+1      STRING BUFFER FOR CARD COLS 7_72 + E-O-L 
          ENTRY  SBUFF
*CALL DBGCOM
 SCANNER  TITLE  MAIN LOOP
*** 
*         SCANNER - TYPES AND TRANSFORMS STATEMENTS INTO E LIST 
*         ON EXIT 
*         TYPE AND B7 = STATEMENT TYPE
*         CLABEL = LABEL IN DISPLAY CODE, LEFT JUSTIFIED
*         SELIST - FWA OF THE E LIST
*         ELAST - LWA OF E LIST    (  ELAST < SELIST )
*         LTYPE - TYPE OF STMT AFTER A LOGICAL IF 
*         LELIST - LOCATION OF STMT AFTER LOGICAL IF
*         DUKE - LINE COUNT IN BINARY 
  
  
 SCANNER  ENTRY. **          ** ENTRY/EXIT ** 
  
 SCANNER1 SX6    CONSTOR     _ FWA *CONSTOR*
          SA1    SYMEND      _ LAST SYMBOL TABLE ENTRY
          SX7    X1-L.STBZ
          SA6    CCSTO       INITIALIZE 'CONSTOR' POINTER 
          SB1    1
          SA7    SELIST      _ FWA E-LIST WORKING STORAGE 
          SX6    X7+B1
          MX7    60 
          SA6    ELAST
          SA7    TYPE        INITIALIZE *TYPE* TO UNTYPED (-0)
          SETZERO   O.VAR,L.VAR 
          BX6    X6-X6
          MX7    0
          SA6    LTYPE
          SA7    LELIST 
  
 SCAN2    BSS    0           IN NON-DEBUG MODE, *EQ SCAN13* PLUGGED HERE
          SA1    =XDFLAG
          SB2    SCAN2
          BSS    0           TERMINATE PLUG SITE
  
          ZR     X1,SCAN3    IF DEBUG OPTION NOT SELECTED 
          SA1    D.COL
          MX6    0
          SA6    A1 
          NZ     X1,SCAN4    IF DEBUG EXT PACKET JUST ENDED 
          SB2    SCAN3
  
 SCAN3    BSS    0           IF DEBUG MODE, *EQ SCAN13* PLUGGED HERE
          PLUG   AT=B2,TO=SCAN10
          BSS    0           TERMINATE PLUG SITE
  
 SCAN4    SX6    B0 
          MX7    1
          SA6    DUKE1
          SA7    IEF         SET *DEFER LISTING* STATUS 
          SA6    NLABEL 
          SA1    =A.0.
          SA6    CARDS
          BX6    X1 
          SA6    FTNCNT 
          SA6    SCNT 
  
*  CHECK FOR AVAILABILITY OF FIRST SOURCE LINE IMAGE. 
  
          SA1    CP.CARD
          NZ     X1,SCAN5    IF NEW SOURCE LINE IN BUFFER 
          PL     X1,SCAN8    IF NO LINE 
 SCAN5    BSS    0
  
 #RM      IFEQ   CP#RM,0
  
          SA1    =XCP.CARD
          MX6    -12
          SB6    A1          (B6) = LINE FWA
 SCAN6    BX7    -X6*X1 
          SA1    A1+B1
          NZ     X7,SCAN6    IF NO 12-BIT ZERO BYTE EOL TERMINATOR
          SB6    A1-B6       (B6) = LINE LENGTH (WORDS) 
  
 #RM      ELSE
  
*         TERMINATE SOURCE INPUT LINE WITH AT LEAST 12-BIT ZERO BYTE. 
  
          SA2    =XF.IN      (X2) = ADDRESS OF INPUT FILE FIT 
          FETCH  X2,RL,X1    RETURNS (X1) = RECORD LENGTH (CHARACTERS)
          IX2    X1+X1
          CW     X3,X1
          LX1    X2,B1
          SB6    X3          (B6) = RECORD LENGTH (WORDS) 
          IX2    X2+X1       RECORD LENGTH (BITS) 
          BX4    X3 
          LX3    6
          NZ     B6,SCAN6A   IF RECORD LENGTH NOT ZERO
          SB6    B1 
 SCAN6A   SA1    =XCP.CARD-1+B6 (X1) = LAST WORD OF LINE
          LX4    2
          IX3    X3-X4       60 * WORD COUNT = LINE LENGTH (BITS) 
          MX4    1
          IX3    X3-X2       UNUSED BIT COUNT 
          SB2    X3-59D 
          AX4    -B2
          BX6    X4*X1       DISCARD UNUSED BITS
          AX4    6
          SA6    A1 
          NZ     X4,SCAN7    IF LINE TERMINATOR AT LEAST 12 BITS LONG 
          MX7    0
          SB6    B6+B1       INCREMENT RECORD LENGTH
          SA7    A6+B1       TERMINATE LINE WITH 60 ZERO BITS 
 SCAN7    BSS    0
  
 #RM      ENDIF 
  
*         SIMULATE THE WAY /COMFRNC/ HANDLES END-OF-LINE BY GUARANTEEING
*           THAT THE EOL MARK IS ON A WORD BOUNDARY BY APPROPRIATELY
*           BLANK FILLING THE LAST WORD OF THE LINE IMAGE AND STORING 
*           A FULL WORD EOL MARK AFTER IT.
  
          SA1    =XCP.CARD+B6-1 (A1,X1) = A+C OF LAST WORD OF LINE IMAGE
          NZ     X1,SCAN7A   IF NOT FULL WORD EOL MARK
          SA1    A1-B1
          MX0    -6 
          BX2    -X0*X1 
          NZ     X2,SCAN7B   IF NOT 11 CHAR (66 BIT) EOL MARK, NO BLANK 
*                              FILL NEEDED... 
          SB6    B6-B1
  
 SCAN7A   SB6    B6+B1
          RJ     =XSFN       SPACE FILL NAME
          BX7    X7-X7
          SA6    A1 
          SA7    A6+B1       MARK FULL WORD EOL 
  
 SCAN7B   SX6    B6 
          SX7    B6+2 
          SA6    L.CARD      SOURCE LINE LENGTH 
          SA7    L.PLINE     LISTING LINE LENGTH
          EQ     SCAN9
  
 SCAN8    RJ     RNC         READ NEXT CARD 
          SX6    X7+2 
          SA6    L.PLINE
          ZR     X1,SCAN9    IF NEW LINE FOUND
          RJ     DSL         DUMP SAVED LINES 
          SX6    ST.INV      (X6) = *INVENTED END* STATEMENT TYPE CODE
          MX7    0
          SB7    X6          (B7) = STATEMENT TYPE CODE RETURN
          SA6    TYPE 
          SA7    C$STMT      MARK NEXT LINE *NOT DEBUG* 
          EQ     SCANNER     EXIT ... 
  
*         CHECK FOR BLANK, DEBUG OR C/-LIST,NONE LINES. 
  
 SCAN9    RJ     CBL         CLASSIFY AND BURST LINE
          NZ     X5,AFC3     IF COMMENT LINE
          MI     X1,AFC1     IF COLUMNS 7-72 BLANK
          SA1    CSSTMT 
          BX6    X6-X6
          MX0    1
          SA6    BLNKSTMT    CLEAR *BLANK STATEMENT* FLAG 
          MI     X3,SCAN9B   IF A C$-DEBUG STATEMENT.AND.DEBUG MODE ON
          ZR     X1,SCAN10   IF NOT A C/-LIST DIRECTIVE 
          SA2    DUKE1
          BX6    X1*X0       (X6) = 1S59 IF *LIST,ALL* OCCURRED 
*                                 =   0  IF *LIST,NONE* OCCURRED
          SB2    X2 
          NE     B2,B1,SCAN9A      IF C/-LIST DIRECTIVE WAS NOT LINE 1
          SA6    =XNOLIST    PRESET SO THAT IF THIS WAS A C/-LIST,NONE
*                              DIRECTIVE OCCURRING AS LINE 1, IT WILL 
*                              NOT BE LISTED
          SA6    IEF         SET SO THAT IF THIS WAS A C/-LIST,NONE 
*                              DIRECTIVE OCCURRING AS LINE 1, SOURCE
*                              LINES WILL NOT BE SAVED IN 
*                              *BEFORE HEADER* MODE 
 SCAN9A   RJ     PLO         PROCESS C/-LIST OPTIONS
          EQ     SCAN10      REJOIN NORMAL FLOW...
  
 SCAN9B   MX4    1
          BX6    X3*X4
          LX6    1           (C$STMT) = +0 IF NEXT STMT IS NOT C$ DEBUG 
*                                     =  1 IF NEXT STMT IS C$ DEBUG 
          SA6    A3 
          NZ     X2,AFC2     IF A DEBUG CONTINUATION CARD -- ILLEGAL
          EQ     SCAN13 
 AFC      SPACE  4,8
*         ABNORMAL FIRST CARD(S). 
  
 AFC1     BX4    X4+X2
          ZR     X4,AFC3     IF LABEL + CONTIN FIELDS EMPTY, BLANK LINE 
 AFC2     SA3    FTNCNT 
          BX6    X6-X6
          LX7    X3 
          SA6    BADLABL     CLEAR BAD LABEL FLAG 
          SA7    SCNT        UPDATE ERROR MSG LINE NUMBER 
          POSTER SEV=FE,NR=E29
          SB1    1
 AFC3     RJ     PBC         PROCESS BLANK OR COMMENT LINE
          RJ     PLR         PROCESS LISTING REQUEST
          EQ     SCAN8       LOOP FOR NEXT LINE 
 SCAN10   SPACE  4,8
**        CHECK FOR COMPASS SUBPROGRAM. 
  
 SCAN10   SA1    IDENTOK
          NZ     X1,SCAN11   IF PROGRAM UNIT HEADER FOUND OR INVENTED 
          CALL   CCS         CHECK FOR AND COPY COMPASS SOURCE INPUT
          ZR     B7,SCAN13   IF NO *IDENT* LINE FOUND 
          EQ     SCAN4       RE-INITIALIZE FOR NEW PROGRAM UNIT 
  
 SCAN11   SA1    =XDFLAG
          SB2    SCAN2
          ZR     X1,SCAN12   IF DEBUG OPTION NOT SELECTED 
          SB2    SCAN3
 SCAN12   PLUG   AT=B2,TO=SCAN13
 SCAN13   SPACE  4,8
**        BEGIN FORTRAN STATEMENT PROCESSING. 
  
 SCAN13   SA1    FEFLAG 
          MX6    0
          SA6    A1 
          ZR     X1,SCAN14   IF NO FATAL ERROR IN LAST STATEMENT
          RJ     LSL         LIST SAVED STATEMENT 
 SCAN14   RJ     PLO         PROCESS C/-LIST OPTIONS
          RJ     PLR         PROCESS LISTING REQUEST (NEW STATEMENT)
          SA1    SBUFLG 
          SA3    BADLABL
          MX6    0
          SA6    A1 
          PL     X1,SCAN15   IF LAST STMT NOT TERMINATED BY $ 
          SA6    CONTCNT     CLEAR CONTINUATION CARD COUNT
          EQ     SCAN16      BYPASS SOURCE LINE COUNT UPDATE
  
 SCAN15   SA2    DUKE1       LINE COUNT (BINARY)
          SA4    FTNCNT 
          BX6    X2 
          LX7    X4 
          SA6    DUKE        UPDATE BINARY LINE COUNT 
          SA7    SCNT        UPDATE START-OF-STMT LINE COUNT FOR 'ERPRO'
 SCAN16   ZR     X3,SCAN17   IF NO BAD LABEL
          BX7    X7-X7
          SA7    A3 
          POSTER SEV=FE,NR=E30
 SCAN17   SPACE  4,8
**        LEXICALLY SCAN STATEMENT. 
  
 SCAN17   RJ     LEX
 SCAN17   SPACE  4,8
**        TERMINATE STATEMENT SCAN. 
  
          ELPUT  EOS
          SA2    PARENS 
          SA3    C$STMT 
          MX4    1
          BX6    X3*X4
          LX6    1           (C$STMT) = +0 IF NEXT STMT IS NOT C$ DEBUG 
*                                     =  1 IF NEXT STMT IS C$ DEBUG 
          SA6    A3 
          ZR     X2,SCAN18   IF PARENS ARE BALANCED 
          NZ     X3,SCAN18   IF C$ DEBUG STATEMENT
          SX3    1R(
          AX2    59-0 
          MX6    -1 
          BX7    X2*X6       (X7) = -1 IF (PARENS) .MI. 
*                                 = +0 IF (PARENS) .PL. 
          IX3    X3-X7
          LX3    48-6 
          MX7    0
          SA7    A2 
          POSTER SEV=FE,NR=E33,FMT=DPC,TXT=X3  *UNMATCHED PARENTHESIS*
 SCAN18   SA4    TYPE 
          SA1    LELIST 
          PL     X4,SCAN19   IF TYPE WAS DETERMINED 
  
*         SET TYPE *BAD* FOR ERRONEOUS STATEMENT SO THAT THE PHASE
*         CONTROLLER CAN PROCESS THE LABEL DEFINITION, IF ANY, AND
*         CAN TURN C$ DEBUG OPTIONS ON OR OFF.
  
          SX7    ST.BAD      *BAD* STATEMENT TYPE CODE
          BX4    X7 
          SA7    A4 
 SCAN19   ZR     X1,SCAN21   IF NOT ONE-BRANCH *IF* 
          PL     X1,SCAN20   IF OBJECT OF *IF* ALREADY TYPED
          SA3    ELAST
          SA5    SELIST 
          BX7    X4 
          MX0    -1 
          SX6    X3-2 
          SA7    LTYPE
          SA6    A3 
          BX7    X5 
          IX6    X6+X0
          SA7    A1 
          SA6    A5 
          MX7    -0 
          SA7    A4 
          EQ     SCAN17      LEXICALLY SCAN OBJECT OF ONE-BRANCH *IF* 
  
*         UNSWITCH ONE BRANCH *IF* TYPE CODES AND POINTERS. 
* 
*         (LELIST)=ADDR OF BEGINNING OF *ELIST* FOR ENTIRE STMT.
*         (SELIST)=ADDR OF BEGINNING OF *ELIST* FOR OBJECT OF *IF*. 
*         (LTYPE)=STMT TYPE CODE FOR 1ST *IF*.
*         (TYPE)=STMT TYPE CODE FOR OBJECT OF ONE BRANCH *IF*.
* 
*         E.G. - IF (A.EQ.B) GOTO  100
*                '  '         '    '
*           (LTYPE)(LELIST) (TYPE)(SELIST)
* 
 SCAN20   SA2    SELIST 
          BX6    X1 
          LX7    X2 
          SA3    LTYPE
          SA6    A2 
          BX6    X3 
          SA7    A1 
          LX7    X4 
          SA6    A4 
          SA7    A3 
  
 SCAN21   SB1    1
          CALL   TDI         TRANSFER DEBUG INFORMATION 
  
 .T       IFNE   TEST,0 
          SA1    =XCO.SNAP
          SX7    B1          (X7) = *EOS* CHECK FLAG ON 
          LX1    1RE
          PL     X1,SCAN22   IF SNAP=E NOT SELECTED 
          AX1    59 
          BX6    X1*X7       (X6) = LIST CONTROL FLAG 
          RJ     DEL         DUMP E-LIST
 SCAN22   BSS    0
 .T       ENDIF 
  
          SA4    TYPE 
          SA5    NANSI       NON-ANSI TYPE SHIFT WORD 
          SA3    NAFLG
          SB7    X4+         (B7)=STMT TYPE CODE
          LX0    B7,X5
          BX6    X3+X0
          PL     X6,SCANNER  IF NOT NON-ANSI KEYWORD, EXIT... 
          POSTER SEV=ANSI,NR=E299   *THIS STMT IS A NON-ANSI STMT*
          SA4    TYPE 
          SB1    1
          SB7    X4 
          EQ     SCANNER     EXIT...
          TITLE  SUBROUTINES
 ADD1     SPACE  4,8
*** 
*         ADD1 - ADD WORD TO ELIST, GET NEXT CHARACTER, EXIT ON B1
* 
 ADD1     SA2    LWAWORK     ADDRESS OF LAST E-LIST ENTRY 
          SA4    X1          FETCH WORD TO BE STORED IN E-LIST
          MX5    -1R.        SHIFT TEST MASK FOR ILLEG CHARS 00B, 60_77B
          SA1    COLS        NEXT COLUMN COUNTER
          SX6    X2-1        CURRENT E-LIST ENTRY ADDRESS 
          SA3    FWAWORK     END ADDRESS (LOWEST) OF E-LIST 
          BX7    X4 
          SA6    A2          UPDATE ENTRY ADDRESS 
          SA4    X1+SBUFF    GET NEXT COLUMN
          IX0    X3-X6
          SA7    X6          STORE THE NEW ENTRY IN E-LIST
          MI     X0,ADD1.2   IF E-LIST SPACE NOT FULL 
          EQ     ERP1 
  
 ADD1.2   SB7    X4+7777B    BIAS ILLEGAL CHAR TO 7777B OR 10057_10076B 
          AX0    B7,X5       B7 IS TRANSFERRED TO SHIFT UNIT MODULO 64
          SB2    X4          SAVE CHARACTER FOR NEXT USER 
          ZR     X0,ADD1.4   IF ILLEGAL CHARACTER OR E-O-L
          SX7    A4-SBUFF+1 
 ADD1.3   SA7    COLS        UPDATE COLUMN POINTER
          JP     B1          EXIT TO NEXT STATE 
  
 ADD1.4   RJ     PGCOM
          NZ     B4,ADD1.2   IF NOT STARTING DELIMITED HOLLERITH STRING 
          SX7    A4-SBUFF+1 
          EQ     ADD1.3 
 ADJ      TITLE  ADJ - REMOVE LEADING LABEL AND/OR VARIABLE FROM STRING.
**        ADJ - REMOVE LEADING LABEL AND/OR VARIABLE FROM STRING
* 
*                REMOVES A LABEL AND/OR A VARIABLE NAME FROM THE
*         KEYWORD STRING AND MAKES THE APPROPRIATE *ELIST* ENTRIES FOR
*         THEM. CONSIDER THE STATEMENT -- 
* 
*                DO100IV=1,10 
* 
*                UPON ENTRY TO *ADJ*, *SRCH* WILL ALREADY HAVE STRIPPED 
*         OFF THE KEYWORD *DO*. *ADJ* SPLITS *100IV* INTO *100* AND *IV*
*         AND MAKES THE *ELIST* ENTRIES FOR THEM. 
* 
*         ENTRY  (KEYL) = 12/2000B+NR CHRS IN STRING,48/NR WDS IN STRING
*                (KEYW) = KEYWORD STRING, WITHOUT THE KEYWORD, LEFT 
*                         JUSTIFIED, ZERO FILL. 
*                (B1)  =  NEXT *LEX-N-* JUMP ADDRESS. 
*                (B2)  =  NEXT CHARACTER IN STATEMENT.
*         EXIT   (B1)  =  UNCHANGED 
*                (B2)  =  UNCHANGED 
*         USES   ALL REGISTERS EXCEPT B1,B2.
* 
*         CALLS  PVN
*                MCE
  
 ADJ      SUBR               ** ENTRY/EXIT ** 
          SA2    KEYL 
          NO
          UX2    B3,X2       (B3)=NR CHAR LEFT IN *KEYW*
          ZR     B3,EXIT.    IF NOTHING LEFT
          SA1    KEYW 
          SA2    =05050505050505050505B 
          SA4    =40404040404040404040B 
          IX3    X1+X2       (X3)=SIGN BIT FOR EACH CHAR THAT WAS DIGIT 
*                              WILL BE ON.
          SX7    0
          BX6    -X3*X4      EXTRACT *SIGN* BITS FOR LETTERS
          SA7    LCON 
          PL     X3,ADJ3     IF A NAME
  
*         EXTRACT LABEL FROM   LABEL ALPHANUMERIC.
  
          AX6    12 
          PX7    X6 
          NO
          NX0    B4,X7       (B4)=6*NR DIGITS IN LABEL
          ZR     X0,ERP9     IF MORE THAN 7 DIGITS IN LABEL 
          SB6    B4-B5
          MX7    1
          AX0    B6,X7       (X0)=MASK(6*NR CHRS IN LABEL)
          BX4    X0*X4
          CX5    X4 
          SB7    X5          (B7)=NR OF DIGITS IN LABEL 
          BX2    X0*X1       EXTRACT LABEL
          SA3    =10H 
          BX4    -X0*X3      AND SPACE FILL IT
          BX6    X2+X4
          SA6    LCON 
  
*         LEFT JUSTIFY REST OF STRING.
  
          BX1    -X0*X1      MASK OFF LABEL FROM REST OF STRING 
          SA2    A1+B5
          BX3    X0*X2
          IX0    X3+X1
          LX1    B4,X0
          SB3    B3-B7       ADJUST CHAR COUNT
  
*         FORM *ELIST* ENTRY FOR AN INTEGER LABEL.
  
          SX3    B7 
          SA2    ADJA 
          SA5    CCSTO       (X5)=*CONSTOR* ADDR FOR LABEL
          LX3    18 
          BX6    X2+X3
          SA4    SELIST 
          IX6    X6+X5       12/2000,3/1,9/0,18/NR DGTS,18/(CCSTO)
          ZR     B3,ADJ2     IF NO VARIABLE 
          SX4    X4+1 
  
*         ADJUST (SELIST).
  
 ADJ2     SA6    X4+B5
          SX7    A6          ADJUST ELIST START ADDRESS 
          SA7    A4+
          ZR     B3,ADJ4     IF NOTHING LEFT
          SA2    TYPE 
          SX3    X2-ST.ASG
          NZ     X3,ADJ3     IF NOT AN *ASSIGN* STMT
  
*         PROCESS *ASSIGN* STATEMENT. 
  
          MX0    12 
          BX2    X0*X1
          NO
          LX2    12 
          SX3    X2-2RTO
          NZ     X3,ERP8     IF *TO* MISSING
          SB3    B3-2        ADJUST CHAR COUNT
          BX1    -X0*X1 
          LX1    12 
          ZR     B3,ERP8     IF NAME MISSING
  
*         PROCESS VARIABLE NAME.
  
 ADJ3     LX1    -12
          SB6    B3+         NR CHRS IN NAME
          BX6    X1          12/0,48/NAME,DPC LEFT JUST, ZERO FILL
          RJ     PVN         PROCESS VARIABLE NAME
          SA3    LCON 
          SA4    SELIST 
          ZR     X3,ADJ5     IF NO PRECEDING LABEL
          SA6    X4-1        NAME TO ELIST
  
*         PROCESS LABEL.
  
 ADJ4     SA3    LCON 
          BX6    X3 
          RJ     MCE         MAKE *CONSTOR* ENTRY 
          EQ     EXIT.
  
 ADJ5     SA6    X4+B5       STORE NAME IN ELIST
          SX7    X4+1        UPDATE *SELIST*
          SA7    A4 
          EQ     EXIT.
  
*         INTEGER LABEL *ELIST* ENTRY SKELETON. 
  
 ADJA     VFD    12/2000B,3/1,27/0,18/0 
 ANSIERP  SPACE  4,8
*** 
*         ANSIERP - NON-ANSI DIAGNOSTIC REPORTING INTERFACE 
* 
*         ON ENTRY - X0 = ERROR NUMBER
* 
*         REGISTERS SAVED AND RESTORED -       X3,   X5,X6
*                                        B1,B2,B3,      B6
  
  
 ANSIERP  SUBR               ** ENTRY/EXIT ** 
          RJ     SAV         SAVE PACKING REGISTERS 
          SB6    X0          (B6) = ERROR MESSAGE NUMBER
          POSTER SEV=ANSI,NR=** 
          RJ     RES         RESTORE PACKING REGISTERS
          EQ     EXIT.
 AWE      SPACE  4,8
**        AWE - ADD WORD TO E-LIST. 
* 
* 
*         ENTRY  (X1) = WORD TO BE ADDED TO E-LIST
* 
*         USES   X - 2, 3, 6, 7 
*                A - 2, 3, 6, 7 
*                B - 3, 4 
* 
*         CALLS  NONE 
  
  
 AWE      SUBR               ** ENTRY/EXIT ** 
          SA2    =XLWAWORK
          SA3    =XFWAWORK
          BX6    X1 
          SB3    X2-1 
          SB4    X3 
          SA6    B3          WORD TO E-LIST 
          SX7    B3+
          SA7    A2          ADVANCE E-LIST POINTER 
          GT     B3,B4,EXIT. IF E-LIST OVERFLOW NOT IMPENDING 
          EQ     ERP1 
 CBL      TITLE  CLASSIFY AND BURST LINE
**        CBL - CLASSIFY AND BURST LINE.
* 
*                *CBL* DOES THE FOLLOWING FOR EACH SOURCE LINE ...
*         1.  UPDATES SOURCE LINE COUNT.
*         2.  CLASSIFIES THE LINE INTO ONE OF THESE CATEGORIES -- 
*             A.  COMMENT LINE. 
*             B.  INITIAL STATEMENT LINE. 
*             C.  CONTINUATION LINE.
*             D.  C$ DEBUG LINE.
*             E.  C/ LIST LINE. 
*         3.  UPDATES OR RESETS CONTINUATION LINE COUNT.
*         4.  EXTRACTS LABEL. 
*         5.  BURSTS LINE TO *SBUFF*, ONE CHARACTER PER WORD, WITH
*             BLANKS SQUEEZED OUT.
* 
* 
*         ENTRY  (CP.CARD) ET SEQ = PACKED SOURCE LINE. 
*                (L.CARD) = SOURCE LINE LENGTH (INCLUDES FULL WORD EOL) 
*                (NLABEL) = LABEL OF LAST LINE. 
* 
*         EXIT   LINE COLUMNS 7-72 BURST TO STRING BUFFER *SBUFF*.
*                  BLANKS ARE SQUEEZED OUT.  LEADING BLANK COUNT (LBC)
*                  IS PACKED WITH NON-BLANK CHARACTER AS FOLLOWS -- 
*                            12/LBC+2001B, 42/0, 6/CHARACTER
*                  *SBUFF* TERMINATOR FORMAT -- 
*                            12/-(LBC+2001B),48/-1
* 
*                LABEL PROCESSING FOR NON-CONTINUATION LINE --
*                  (CLABEL)  = LABEL OF LAST LINE FROM (NLABEL).
*                  (NLABEL)  = NEW LABEL, DPC, LEFT JUSTIFIED, BLANK
*                              FILLED, LEADING ZEROS SQUEEZED OUT.
*                            = .ZR. IF LABEL ABSENT OR NON-NUMERIC (BAD)
*                  (BADLABL) = .MI. IF LABEL BAD, ELSE UNCHANGED. 
*                  IF CONTINUATION LINE, THE LABEL FIELD IS IGNORED.
* 
*                REGISTER AND CELL CONTENTS --
*                (A1,X1) = SBUFF,   1ST NON-BLANK CHAR IN STRING BUFFER.
*                (A2,X2) = CONTCNT, UPDATED CONTINUATION LINE COUNT.
*                (A3,X3) = DTYPE,   +1 IF C$ DEBUG LINE AND DEBUG ON. 
*                        =          +0 IF ELSE. 
*                (A4)    = NLABEL,  NEW LINE LABEL. 
*                   (X4) =          (NLABEL) IF GOOD LABEL PRESENT. 
*                        =          .ZR. IF LABEL ABSENT. 
*                        =          .NZ. IF LABEL BAD (NON-NUMERIC).
*                (X5)    =          +1 IF COMMENT LINE, +0 IF NOT.
*                (B1)    =          1 
*                (B5)    =          1 
*                (COLS)  =          0 
* 
*         USES   ALL BUT A0.
* 
*         CALLS  CDD,CLO,POSTERR
  
  
 CBL      SUBR               ** ENTRY/EXIT ** 
  
*         UPDATE SOURCE LINE NUMBERS. 
  
          SA5    DUKE1       INCREMENT BINARY LINE NUMBER 
          SA2    FTNCNT      INCREMENT DISPLAY-CODED LINE NUMBER
          MX6    -1 
          SB1    1
          IX7    X5-X6
          SA3    =1H
          IX6    X2-X6       (X6) = DPC + 1 
          MX4    -6 
          BX1    X7          (X1) = BIN + 1 
          SX0    41B         (X0) = SHIFT TEST MASK FOR CHARS 5 AND + 
          SA7    A5          UPDATE BINARY
  
 .T       IFNE   TEST,0 
          SA2    =XCO.SNAP
          ZR     X2,CBL1           IF SNAP = 0
          CALL   CDD
          BX7    X6 
          EQ     CBL3        NUMBER EACH SOURCE LINE UNCONDITIONALLY
  
 CBL1     BSS    0
 .T       ENDIF 
  
          BX2    -X4*X6 
          LX0    59-1R+ 
          SB2    X2          (B2) = DPC UNITS POSITION CHARACTER
          BX7    X3          (X7) = 10 BLANKS 
          ZR     X5,CBL2     IF LINE 1, NUMBER IT UNCONDITIONALLY 
          LX0    B2 
          PL     X0,CBL3     IF LINE NUMBER NOT MULTIPLE OF 5 
          LX0    1R+-1R5     CHECK 9-0 OVERFLOW (DPC ADD FAILS) 
          MI     X0,CBL2     IF UNITS CHARACTER = 5 (DPC ADD OK)
          CALL   CDD         CONVERT (X1) BINARY TO (X6) DECIMAL DPC
 CBL2     BX7    X6          (X7) = DPC 
 CBL3     SA6    FTNCNT      UPDATE DPC 
          SA7    =XCP.FLIN   DPC OR 10 BLANKS TO SOURCE LISTING BUFFER
  
*         INITIALIZE FOR CLASSIFYING LINE.
  
          SA1    =XCP.CARD   (X1) = SOURCE LINE COLS 1-10 
          SA2    L.CARD 
          SA5    =1H         (X5) = TEN BLANKS (THRU *BURST6*)
          MX6    0           (X6) = 0 (THRU *CAT6*) 
          SX7    B1          (X7) = 1 (THRU *LABL3*)
          SB6    X2-1        (B6) = NR OF USEABLE WORDS IN SOURCE LINE
*                              I.E. DOES NOT INCLUDE FULL WORD EOL MARK 
          MX2    -6          (X2) = 1-COL EXTRACT MASK (THRU *BURST6*)
          SA6    COLS        INITIALIZE COLUMN POINTER
  
*         CHECK FOR COLUMNS 1-6 BLANK.
  
          MX0    6*6
          BX3    X1-X5
          LX1    6*6         RIGHT ADJ COL 6 FOR FALL-THRU TO 'BURST' 
          BX3    X0*X3
          NZ     X3,CAT2     IF COLUMNS 1_6 NOT ALL BLANK 
          SA6    CONTCNT     CLEAR CONTINUATION COUNT 
          EQ     LABL3       BYPASS FURTHER ANALYSIS; GO UPDATE LABEL 
 #NL      IFNE   #NL,0
  
*         CHECK FOR C/ LINE.
  
 CAT2     SA3    =6RC/
          MX0    -6*6 
          BX3    X1-X3
          NO
          BX3    -X0*X3 
          NZ     X3,CAT2A    IF NOT *C/    * LINE 
          SA6    CONTCNT     CLEAR CONTINUATION COUNT 
          SA7    CSSTMT      SET TO *C/ LINE OCCURRED*
          EQ     BURST1      IGNORE LABEL...
 #NL      ELSE
 CAT2     BSS    0
 #NL      ENDIF 
  
*         CHECK FOR COMMENT (C $ * IN COL 1) LINE.
  
 CAT2A    LX1    1*6-6*6     RIGHT JUSTIFY COLUMN 1 
          SA3    COL1MASK    SHIFT TEST MASK FOR C $ *
          BX0    -X2*X1      COLUMN 1 ONLY
          SB5    X0+B1       PREVENT MODULO 60 PROBLEM, SEE *COL1MASK*
          SB2    X0-1RC 
          LX3    B5 
          PL     X3,CAT5     IF NOT ( C $ * ) IN COLUMN 1 
          ZR     B2,CAT2B    IF -C- IN COL 1
  
*         HERE IF NON-ANSI COMMENT LINE.
  
          SA3    NACOM       INCREMENT NON-ANSI COMMENT LINE COUNT
          SX6    X3+B1
          SA6    A3 
  
*         CHECK FOR C$ DEBUG LINE.
  
 CAT2B    SA3    DFLAG
          ZR     X3,CAT3     IF DEBUG MODE OFF, IT IS A COMMENT CARD
          SA3    =5RC$
          LX1    -1*6+5*6    RIGHT ADJUST COLUMN 5
          BX3    X1-X3
          MX0    5*6
          BX3    -X0*X3 
          ZR     X3,CAT4     IF DEBUG CARD (AND DEBUG MODE ON)
  
*         HERE IF COMMENT LINE. 
  
 CAT3     SA7    NXCOMENT    COMMENT LINE FLAG ON 
          EQ     CBL90       BYPASS FURTHER CLASSIFICATION AND BURSTING 
  
*         HERE IF C$ DEBUG LINE.
  
 CAT4     SA3    C$STMT 
          LX1    -5*6+1*6    RIGHT JUSTIFY COLUMN 1 
          BX7    -X3
          SA7    A3+         SET TO *NEXT STATEMENT IS C$ DEBUG*
          MX7    0           SET *THIS STMT IS C$-DEBUG* FLAG FOR *CAT6*
  
*         CHECK FOR CONTINUATION LINE.
  
 CAT5     SA3    ZRBLMASK    SHIFT TEST MASK FOR /0/ OR / / 
          LX1    -1*6+6*6    RIGHT ADJUST COLUMN 6
          BX0    -X2*X1 
          SB5    X0 
          LX0    X3,B5
          MI     X0,CAT6     IF NOT A CONTINUATION CARD 
  
*         HERE IF CONTINUATION LINE.
  
          SA3    CONTCNT
          SX6    X3+B1       CONTINUATION COUNT + 1 
          SA6    A3 
          SA3    C$STMT 
          ZR     X3,CAT5.5   IF NOT PROCESSING C$-DEBUG 
          ZR     X7,CAT5.5   IF C$-DEBUG WITH A C$ IN COLS 1-2
  
          DBGERR (NON-DEBUG CONTINUATION STATEMENT) 
          EQ     CBL90
  
 CAT5.5   PL     X3,BURST1   IF CONTINUATION LINE WITHOUT C$
          SA3    D.CURT 
          MI     X3,BURST1   IF CURRENT STMT IS C$
          SX7    B1          SET COMMENT LINE FLAG
          EQ     CAT3        IT IS A COMMENT LINE 
  
*         HERE IF NON-CONTINUATION LINE.
  
 CAT6     SA6    CONTCNT     SET CONTINUATION COUNT TO ZERO 
          ZR     X7,LABL3    IF DEBUG CARD, NO LABEL - BYPASS PACKING 
          BX0    X3          SAVE (X3)
          SA3    =XDFLAG
          AX3    1
          NZ     X3,BURST1   IF INPUT FILE= EXTERNAL DEBUG FILE ,IGNORE 
          BX3    X0          RESTORE (X3) 
  
*         PACK LABEL IN COLS 1 THRU 5 TO (X6).  BLANKS AND LEADING
*           ZEROES ARE IGNORED. 
  
          MX7    1R9-1R0+1   DIGIT SHIFT TEST MASK
          SB5    5           (B5) = COLUMN COUNTER
          LX7    -1R0        POSITION TEST MASK CORRECTLY 
          SB2    60          PACKING SHIFT COUNTER
          LX1    -6*6+1*6    RIGHT ADJUST COLUMN 1
  
*  ????   BEGIN 6600 IN-STACK LOOP
  
 LABL1    ZR     B5,LABL2    IF COLUMNS 1-5 PROCESSED 
          BX0    -X2*X1      NEXT COLUMN
          LX1    1*6
          SB4    X0 
          SB5    B5-1        COLUMN COUNT - 1 
          LX0    X3,B4       ZERO/BLANK TEST MASK 
          MI     X0,LABL1    IF BLANK OR LEADING ZERO 
          LX0    X7,B4       DIGIT TEST MASK
          SX3    B4 
          SB2    B2-6        PACKING SHIFT COUNT - 6
          LX3    B2,X3
          BX6    X6+X3
          SX3    1BS14       TURN OFF LEADING ZERO SUPPRESS BIT IN MASK 
          MI     X0,LABL1    IF A LEGAL DIGIT 
  
*  ILLEGAL CHARACTER IN LABEL FIELD 
  
          MX3    60          PREVENT FURTHER PACKING
          BX6    X6-X6       CLEAR PACKING REGISTER 
          SA7    BADLABL     BAD LABEL FLAG ON
          EQ     LABL1       CONTINUE SCAN SO X1 POSITIONED CORRECTLY 
  
*  ''''   END IN-STACK LOOP 
  
*  FINAL LABEL PROCESSING 
  
 LABL2    SA4    =40404040404040404040B 
          SB7    60-5        (B7) = RIGHT CIRCULAR SHIFT 5 BITS 
          ZR     X6,LABL3    IF BAD LABEL, BYPASS BLANK FILL... 
          SX7    B1          REPLACE ZERO FILL WITH BLANK FILL
          IX3    X6-X7       ?
          BX0    -X6*X3      ?
          NO                 ?
          BX3    X4*X0       ?
          LX0    X3,B7       ?
          IX7    X3-X0       ?
          BX3    X3+X7       ?
          BX0    X3*X5       ?
          IX6    X6+X0       .... DONE
  
 LABL3    SA3    NLABEL 
          SB0    B0+
          BX7    X3 
          SA6    A3          NEW LABEL (NEXT CARD)
          SA7    CLABEL      PREVIOUS LABEL 
  
*  BURST CARD COLUMNS 7-72 INTO STRING BUFFER; SQUEEZE OUT BLANKS 
  
 BURST1   MX3    1           10-CHARACTER BURST SHIFT COUNTER 
          SB4    7
          SB2    B0          BLANK COUNTER
          LX3    -4*6        INIT 10-CHR COUNTER FOR 4 COLUMNS (7_10) 
          LE     B6,B4,BURST1A     IF LINE HAD 80 OR FEWER COLUMNS
          SB6    B4          LIMIT BURST TO 7 MORE WORDS
 BURST1A  SB5    -1R         (B5) = COMPLEMENTED BLANK
          SA6    SBUFF-1     INITIALIZE BUFFER STORE POINTER
          SB3    72-7+1      (B3) = NR OF COLS REMAINING ON CARD/LINE 
          SX7    1
  
*  ????   BEGIN 6600 IN-STACK LOOP
  
 BURST2   LX1    1*6         RIGHT JUSTIFY NEXT COLUMN
          SB2    B2+B1       BLANK COUNT + 1
          BX6    -X2*X1 
          SB4    X6+B5
          LX3    6           BURST COUNT MASK 
          SB3    B3-B1       COLUMN COUNT - 1 
          ZR     B4,BURST3   IF BLANK COLUMN, BYPASS STORING IN 'SBUFF' 
          PX6    X6,B2       PACK COLUMN AND (LEADING BLANK COUNT + 1)
          SB2    B0+         LEADING BLANK COUNT = 0
          SA6    A6+B1       NON-BLANK COLUMN TO STRING BUFFER
 BURST3   PL     X3,BURST2   IF WORD NOT FULLY BURST
          SB4    10          CONSTANT FOR 'BURST5'
  
 BURST4   SB6    B6-B1       WORD COUNT - 1 
          SA1    A1+B1       (X1) = NEXT 10 SOURCE COLUMNS
          LE     B6,BURST6   IF LAST SOURCE WORD OR ONE BEYOND (FINIS)
  
 BURST5   IX0    X1-X5       SUBTRACT FULL WORD OF BLANKS 
          NZ     X0,BURST2   IF WORD NOT ALL BLANK
          SB2    B2+B4       BLANK COUNT + 10 
          SB3    B3-B4       COLUMN COUNT - 10
          EQ     BURST4      GET NEXT WORD
  
*  ''''   END IN-STACK LOOP 
  
*         HERE IF NO MORE SOURCE WORDS TO BURST --
*           1. IF COLS 71-72 ARE AVAILABLE, GO BACK AND BURST THEM .OR. 
*           2. IF COLS 71-72 ARE NOT AVAILABLE (LINE ENDED BEFORE 
*                COL 71) OR HAVE ALREADY BEEN BURST, THEN DONE... 
  
 BURST6   ZR     X1,CRDEND   IF EOL ENCOUNTERED, SOURCE LINE EXHAUSTED
          MI     B6,CRDEND   IF JUST FINISHED BURSTING COLS 71 AND 72 
          LX3    -2*CHAR     LIMIT BURST TO 2 CHARS 
          EQ     BURST2      GO BACK FOR COLS 71-72 
  
*         HERE TO MARK END-OF-STRING BUFFER.
  
 CRDEND   SB3    B3+B1       (B3) = NR OF COLS REMAINING ON LINE + 1
          MX0    -1 
          SB2    B2+B3       (B2) = NR OF BLANKS (55B) BETWEEN LAST NON-
*                                     BLANK CHAR ON LINE AND COL 72  + 1
          PX6    B2,X0       (X6) = 12/-(LBC+2001B),48/-1 
          SA6    A6+B1
  
*         CHECK C/ LINE FOR LIST DIRECTIVE. 
  
          RJ     CLO         CHECK FOR C/-LIST OPTION 
  
*         PREPARE FOR RETURN TO CALLER. 
  
 CBL90    SA3    C$STMT 
          BX6    X3 
          SA6    D.CURT 
          SA2    CONTCNT
          ZR     X2,CBL91    IF NOT CONTINUATION LINE 
          BX0    X3 
          AX0    59 
          BX6    X3-X0       (X6) = ABSOULTE VALUE OF (DTYPE) 
          SA6    A3 
 CBL91    SA5    NXCOMENT 
          MX6    60D
          SA6    A5          TENTATIVELY SET *PRIOR COMMENT* STATUS 
          NZ     X5,EXIT.    IF COMMENT LINE
          SA1    CONTCNT
          MX6    0
          SA6    A5          SET *NO PRIOR COMMENT* STATUS
          ZR     X1,CBL95    IF NOT CONTINUATION LINE 
          PL     X5,CBL95    IF CONTINUATION NOT PRECEDED BY COMMENT
          POSTERR   SEV=ANSI,NR=E207
          SB1    1
 CBL95    SA4    NLABEL 
          SA5    BADLABL
          SA1    SBUFF
          SA2    CONTCNT
          SA3    DTYPE
          BX4    X4+X5
          MX5    0
          SB5    1
          EQ     EXIT.
 CLO      SPACE  4,8
 #NL      IFNE   #NL,0
**        CLO - CHECK FOR C/-LIST OPTION. 
* 
*                IF THIS LINE HAD A *C/    * IN COLUMNS 1-6,
*         PACK UP TO 10 CHARACTERS FROM THE STRING BUFFER (SBUFF) AND 
*         CHECK FOR THE OCCURRENCE OF --
*         1) LIST,ALL 
*         2) LIST,NONE
*         FOLLOWED BY AN END-OF-LINE MARK.
* 
* 
*         ENTRY  (CSSTMT)   = .NZ. IF C/ LINE OCCURRED, ELSE .ZR. 
*                (B1)       =  1
* 
*         EXIT   (CSSTMT)   = 1S59 IF C/-LIST,ALL OCCURRED
*                           =  1   IF C/-LIST,NONE OCCURRED 
*                           = +0   IF C/ LINE DID NOT OCCUR OR IF LEGAL 
*                                    C/-LIST DIRECTIVE DID NOT OCCUR
*                (NXCOMENT) =  1   IF LEGAL C/-LIST DIRECTIVE DID NOT 
*                                    OCCUR, THEN LINE BECOMES A LEGAL 
*                                    COMMENT. 
* 
*         USES   X - 0,1,2,3,4,6,7
*                A - 1,2,3,4,6,7
*                B - 6
* 
*         CALLS  NONE 
  
  
 CLO      SUBR               ** ENTRY/EXIT ** 
          SA1    CSSTMT 
          SA2    SBUFF
          ZR     X1,EXIT.    IF NOT A C/ LINE 
          SB6    9
          BX6    X6-X6       (X6) = PACKING REGISTER
          SX7    1
  
*         PACK UP TO 10 CHARACTERS FROM *SBUFF* TO X6.
  
 CLO2     MI     X2,CLO3     IF EOL SENTINEL
          SX2    X2+
          LX6    6
          SB6    B6-1 
          BX6    X6+X2
          SA2    A2+1 
          PL     B6,CLO2     IF STILL ROOM IN PACKING REGISTER
  
*         CHECK FOR LEGAL LIST DIRECTIVE. 
  
 CLO3     SA3    =R.LIST,ALL. 
          SA4    =R.LIST,NONE.
          BX0    X6-X3
          ZR     X0,CLO4     IF *LIST,ALL*
          BX0    X6-X4
          ZR     X0,CLO5     IF *LIST,NONE* 
  
*         HERE IF COMMENT LINE. 
  
          SA7    NXCOMENT    SET TO *COMMENT LINE* STATUS 
          MX6    0
          SA6    A1          SET TO *NOT A C/-LIST DIRECTIVE* 
          EQ     EXIT.
  
*         HERE IF *LIST,ALL* OCCURRED.
  
 CLO4     MX7    1
          SA7    A1          SET TO *LIST,ALL OCCURRED* 
          EQ     CLO6 
  
*         HERE IF *LIST,NONE* OCCURRED. 
  
 CLO5     SX7    1
          SA7    A1+         SET TO *LIST,NONE OCCURRED*
  
*         HERE TO MAKE *NLABEL/CLABEL* TRANSFER.
  
 CLO6     SA1    NLABEL 
          MX6    0
          BX7    X1 
          SA6    A1+
          SA7    CLABEL 
          EQ     EXIT.
 #NL      ELSE
 CLO      SUBR
          EQ     EXIT.
 #NL      ENDIF 
 DEL  SPACE   4,8 
**        DEL - DUMP E-LIST.
* 
*                SETS UP PARAMETER LIST AND CALLS FORTRAN SUBROUTINE
*         TO PRODUCE FORMATTED DUMP OF E-LIST.
* 
* 
*         ENTRY  (X6) = 1 FOR FULL DUMP, = 0 FOR ERRORS DUMP ONLY 
*                (X7) = 1 TO REQUEST *EOS* PRESENCE TEST, ELSE = 0
* 
*         EXIT   E-LIST DUMPED. 
*                (B1) = 1 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 1, 2, 3, 6, 7
*                B - 1
* 
*         CALLS  DMPELST
  
  
 .T       IFNE   TEST,0 
          QUAL   DEL
  
 DEL      SUBR               ** ENTRY/EXIT ** 
          SA6    LISTCMD
          SA7    EOSCHK 
          SA1    ELAST       (X1) = INVERTED LWA OF E-LIST
          SA2    SELIST      (X2) = INVERTED FWA OF E-LIST
          SA3    LELIST      (X3) = INVERTED FWA OF  LOG *IF* E-LIST
          BX6    X1 
          MX4    -1 
          SA6    FWAEL
          IX1    X1+X4
          IX7    X2-X1       (X7) = LENGTH OF ALL E-LIST
          SA7    LENEL
          IX6    X3-X1       (X6) = LENGTH OF E-LIST FOR LOG *IF* TARGET
          SA6    LENLEL 
          SA1    DELA        (A1,X1) = PARAMETER LIST 
          CALL   DMPELST     DUMP E-LIST
          SB1    1
          EQ     EXIT.
  
  
  
*         PARAMETER LIST FOR FORTRAN SUBROUTINE *DMPELST*.
  
 DELA     BSS    0
          CON    TYPE 
          CON    ATYPE
          CON    LTYPE
          CON    CLABEL 
          CON    NLABEL 
 FWAEL    BSSZ   1           = (ELAST)
          CON    1           ADDR OF RA+1 
          BSSZ   1
  
          USE    /DMPEL/
 EOSCHK   BSSZ   1
 LENEL    BSSZ   1
 LENLEL   BSSZ   1
 LISTCMD  BSSZ   1
          USE    *
 SEL      SPACE  4,8
**        SEL - SNAP E-LIST.
* 
*                EXTENSION OF *DEL* FOR SNAPPING E-LIST WITH THE *ELIST*
*         MACRO DEFINED IN *FTNTEXT*.  PROVIDES TRACEBACK TO THE ORIGIN 
*         OF THE SNAP CALL.  SAVES AND RESTORES ALL REGISTERS.
* 
*         ENTRY  NONE 
* 
*         EXIT   NONE 
* 
*         USES   NONE.  ALL REGISTERS ARE SAVED AND RESTORED. 
* 
*         CALLS  DEL, RESET=, SNAP= 
  
  
 SEL      SUBR               ** ENTRY/EXIT ** 
          CALL   SAVE=       SAVE ALL REGISTERS 
          SA1    EXIT.
          SX6    1
          SB1    X6 
          LX6    30 
          IX7    X1+X6       ADVANCE EXIT ADDRESS PAST BCD PARAMETER
          AX1    30 
          SA7    A1 
          SA2    X1          FETCH BCD
          SX1    X1-1        ADDRESS OF ORIGIN OF DUMP REQUEST
          BX6    X2 
          NO
          SA6    SELB        BCD TO DUMP HEADER 
          SB7    SEL2        (B7) = *FRA* RETURN ADDRESS
          EQ     =XFRA=      FIND RELATIVE ADDRESS
  
 SEL2     SA6    SELC 
          NO
          SA7    A6+B1
          LISTL  SELA,L.SELA LIST ORIGIN OF CALL
          SX6    B1          REQUEST FULL DUMP
          MX7    0           REQUEST NO TEST FOR *EOS* PRESENCE 
          RJ     DEL         DUMP E-LIST
          CALL   RESET=      RESTORE REGISTERS
          EQ     EXIT.
  
  
  
 SELA     DATA   H. . 
 SELB     DATA   H.CALLER BCD.
          DATA   H. *** E-LIST DUMP AT. 
 SELC     DATA   C.000000 IN XXXXXXX. 
 L.SELA   =      *-SELA 
          SPACE  4,6
          QUAL   *
 DEL      =      /DEL/DEL 
          ENTRY  DEL
 SEL      =      /DEL/SEL 
          ENTRY  SEL
 .T       ENDIF 
 DIGIT    TITLE  PROCESS NUMERIC CONSTANT 
* DIGIT WHEN A CONSTANT STARTS WITH A DIGIT 
  
 DIGIT    SX7       1 
          SA7       CAD 
          SA7       CTYPE     SET TYPE TO INTEGER 
          SX7    B0           CONSTANT STRING COUNT STARTS AT 0 
          SA7       N 
 PK       RJ        PACKC     DIGIT TO STRING 
          RJ        GET       NEXT NONBLANK CHARACTER 
          SB4       45B       + 
          LT  B2,B4,CFD       JUMP IF NOT SPECIAL 
          SA1    B2+CTAB-45B  LOAD ACTION ADDRESS 
          SB4    X1 
          JP     B4           JUMP TO ACTION
 DIGIT    SPACE  4
 CTAB     VFD    60/TC,60/TC,60/TC,60/TC,60/TC,60/TC,60/TCS,60/TC 
          CON    CERP                  SPECIAL HOLLERITH STRING DELIMITR
          CON    TC                    ,
          CON    KD                    .
 DIGIT    SPACE  4
 CFD      SB4       33B       0 
          GE  B2,B4,PK        DIGIT 
          SB4       5         E 
          EQ  B2,B4,REXPPP    REAL
          SB4       4         D 
          EQ  B2,B4,DEXPPP    DOUBLE
          SB4       2         B 
          EQ  B2,B4,OEXP      OCTAL CONSTANT
          SA1    HLRMASK     SHIFT TEST MASK FOR <H> <L> <R>
          LX0    B2,X1
          MI     X0,HOLLRTH  IF H(OLLERITH), L OR R 
          EQ        CERP      GARBAGE 
 REXPPP   SB2       57B       PUT A DECIMAL POINT IN THE STRING 
          RJ        PACKC          WHEN AN E APPEARS AFTER DIGITS AND 
          SB2       05B       NO DECIMAL POINT
          EQ        REXP
 DEXPPP   SB2       57B       SAME FOR DOUBLE CONSTANTS 
          RJ        PACKC 
          SB2       04B 
          EQ        DEXP
 REXP     SX7       2 
          SA7       CTYPE     REAL
          SA7       EXPEXP    SET EXPECTING EXPONENT FLAG 
          EQ        IIIIC     PUT E IN STRING AND LOOK AT EXPONENT
 DEXP     SX7       3 
          SA7       CTYPE     DOUBLE
          SA7       EXPEXP    SET EXPECTING EXPONENT FLAG 
          EQ        IIIIC     PUT D IN STRING AND LOOK AT EXPONENT
 TC       RJ        PACKT     CONSTANT TERMINATED BY THE CHARACTER
          JP        B1             CHARACTER IN B2
 TCS      RJ     SAV         SAVE PACKING REGISTERS 
          RJ     P$T         PROCESS $ TERMINATOR 
          EQ     NEWS 
  
 KD       SA7       HANG.     TURN ON HANGING . BY SAVING COLUMN COUNTER
          RJ        GET       NEXT CHARACTER
          SX7    B0           TURN OFF HANGING .
          SA7       HANG. 
          SX5    B2 
          SB4       45B       + 
          LT  B2,B4,KDE       NOT SPECIAL 
          SB2       57B       . 
          RJ        PACKC     . TO STRING 
          SB2    X5 
          SX7       2         CONSTANT
          SA7       CTYPE     TYPE IS REAL
          EQ        IIICP 
 KDE      SB4       33B       0 
          LT  B2,B4,KDEQ      NOT DIGIT 
          SB2       57B       . 
          RJ        PACKC     . TO STRING 
          SX7       2 
          SA7       CTYPE     CONSTANT TYPE IS REAL 
          SB2    X5 
          EQ        IIIC
 KDEQ     SB4       5         E 
          EQ  B2,B4,KDEQE     NOW CHECK FOR EXPONENT
          SB4       4         D 
          NE  B2,B4,KDEQD     NOT D 
          SB2       57B       . 
          RJ        PACKC     . TO STRING 
          SB2    X5 
          EQ        DEXP
 KDEQD    RJ        PACKT     TERMINATE CONSTANT
          SB2    X5 
          EQ        POINTT    CHECK FOR RELATIONAL
 KDEQE    MX7       59
          SA7       EXPEXP    EXPECTING SOMETHING 
          RJ        GET       AFTER DIGIT.E 
          MX7       0 
          SA7       EXPEXP    GOT SOMETHING 
          SB4       45B       + 
          GE  B2,B4,POM       SPECIAL 
          SB4       33B       0 
          LT  B2,B4,KDEQQ 
 POMM     SX5    B2           DIGIT 
          SB2       57B       . 
          RJ        PACKC     . TO STRING 
          SB2       5 
          RJ        PACKC     E TO STRING 
          SB2    X5 
          SX7       2         CONSTANT
          SA7       CTYPE     TYPE IS REAL
          EQ        VC        CONTINUE PACKING EXPONENT 
 POM      EQ  B2,B4,POMM      JUMP FOR +
          SB4       46B       - 
          EQ  B2,B4,POMM      JUMP FOR -
          EQ        CERP      NOT AN EXPONENT OR LOGICAL
 KDEQQ    SA5       COLS      RESET 
          SX7    X5-1        COLUMN COUNTER (COLS = COLS-1).
          SB2    1RE         START PROCESSING AT THE *E*. 
          SA7    A5 
          RJ     PACKT       TERMINATE THE INTEGER CONSTANT.
          EQ     POINTT 
* IIIC WHEN EITHER .DIGIT OR DIGITS.
 IIIC     RJ     PACKC        DIGIT OR . TO STRING
          RJ        GET       NEXT NONBLANK CHARACTER 
          SB4       45B       + 
          LT  B2,B4,IIICT     NOT SPECIAL 
 IIICP    SB4       60B 
          GE  B2,B4,CERP      BAD CHARACTER 
          SA1    B2+RTAB-45B
          SB4    X1 
          JP     B4           JUMP TO ACTION
 DIGIT    SPACE  4
 RTAB     VFD    60/TC,60/TC,60/TC,60/TC,60/TC,60/TC,60/TCS,60/TC 
          CON    CERP                  SPECIAL HOLLERITH STRING DELIMITR
          CON    TC                    ,
          CON    TC                    .
 DIGIT    SPACE  4
 IIICT    SB4       33B       0 
          GE  B2,B4,IIIC      DIGIT TO STRING 
          SB4       5         E 
          EQ  B2,B4,REXP
          SB4       4         D 
          EQ  B2,B4,DEXP
          EQ        CERP      GARBAGE 
* IIIIC WHEN EXPECTING AN EXPONENT
 IIIIC    RJ        PACKC     E OR D TO STRING
          RJ        GET       NEXT NON BLANK CHARACTER
          SB4       46B       - 
          EQ  B2,B4,VC
          SB4       45B       + 
          EQ  B2,B4,VC
          GE  B2,B4,CERP      GARBAGE 
          SB4       33B       0 
          LT  B2,B4,CERP      GARBAGE 
          SX7    B0 
          SA7       EXPEXP    TURN OFF EXPECTING EXPONENT FLAG
* VC WHEN PACKING AN EXPONENT 
 VC       RJ        PACKC     + - OR DIGIT IN EXPONENT TO CONSTANT STRIN
          RJ        GET       NEXT NONBLANK CHARACTER 
          SB4       45B       + 
          LT  B2,B4,VCC       NOT SPECIAL 
          SB4       60B 
          GE  B2,B4,CERP      ILLEGAL CHARACTER 
          SA1    B2+RTAB-45B
          SB4    X1 
          JP     B4           JUMP TO ACTION
 VCC      SB4       33B       0 
          LT  B2,B4,CERP      GARBAGE FOR EXPONENT
          SX7    B0 
          SA7       EXPEXP    TURN OFF EXPECTING EXPONENT FLAG
          EQ        VC        PACK THE DIGIT
 OEXP     SX7       5         CODE FOR OCTAL
          SA7       CTYPE 
          RJ        PACKC     B TO STRING 
          RJ        PACKT     E-LIST AND CONSTOR ENTRIES
          SX0    -E197       ERR MSG NR - *NON-ANSI CONSTANT TYPE*
          RJ     ANSIERP
          SB5    1
          RJ     GET         GET NEXT CHARACTER 
          JP     B1          CONTINUE LEXICAL SCAN... 
 PCON     SPACE  4,8
* PCON WHEN . THEN DIGIT
 PCON     MX7    0
          SA7    N           INITIALIZE LENGTH OF CONSTANT STRING 
          SX7    2
          SA7       CTYPE     TYPE TO REAL
          SA7       CAD       STARTING A CONSTANT 
          SX5    B2           SAVE DIGIT
          SB2       57B       . 
          RJ        PACKC     START STRING WITH . 
          SB2    X5           DIGIT TO B2 
          EQ        IIIC      .DIGIT
 DSL      SPACE  4,8
**        DSL - DUMP SAVED LINES. 
* 
*                IF THE SOURCE LISTING OPTION IS ON (L .NZ.) AND
*         NO C/-NOLIST IS ACTIVE, CALLS *LSL* TO LIST SAVED LINES.
  
  
 DSL      SUBR   =           ** ENTRY/EXIT ** 
          SA1    =XSLIST
          SA2    =XNOLIST 
          MX6    0
          BX7    X1*X2
          SA6    IEF         *BEFORE HEADER* FLAG OFF 
          ZR     X7,EXIT.    IF (L=0) OR C/-LIST,NONE ACTIVE
          RJ     LSL         LIST SAVED LINES 
          EQ     EXIT.
 ENDP     TITLE  END LINE PROCESSING
**        ENDP - END LINE PROCESSING. 
* 
*                PERFORMS MISCELLANEOUS HOUSEKEEPING TASKS ASSOCIATED 
*         WITH *END* LINE PROCESSING. 
* 
*         ENTRY  KEYWORD VERIFIED TO BE *END*.
* 
*         USES   X - 1, 2, 3, 6, 7
*                A - 1, 2, 3, 6, 7
*                B - 1
* 
*         CALLS  CDD,POSTER,RNC,SLO 
  
  
 ENDP     SA1    LTYPE
          SA2    NLABEL      LABEL ON *END* LINE, IF ONE
          NZ     X1,ERP3     IF *END* IS OBJECT OF LOGICAL *IF* 
          MX6    0
          BX7    X2 
          SA6    NLABEL 
          SA7    CLABEL 
          RJ     SLO         SET LIST OPTION FLAGS
          SA1    NOEND
          SA2    SBUFLG 
          ZR     X1,END1     IF *END* NOT INVENTED
          SA6    =XCP.CARD   ERASE INVENTED *END* 
          SA6    L.CARD 
 END1     SX7    ST.END      *NORMAL END* STATEMENT TYPE CODE 
          SA7    TYPE 
          MI     X2,END2     IF $ TERMINATED *END*
          NZ     X2,END3     IF NEXT LINE AVAILABLE (*END* CONTINUATION)
          ZR     X1,END2     IF *END* NOT INVENTED
          SX7    ST.INV      *INVENTED END* STATEMENT TYPE CODE 
          SA7    TYPE 
          POSTERR   SEV=INF,NR=E35,RETURN=END4
  
 END2     SB1    1
          RJ     RNC         READ NEXT CARD 
          SX6    X7+2 
          SA6    L.PLINE
          SA1    CONTCNT
          SA2    CLABEL 
          BX6    X1+X2
          ZR     X6,END4     IF ANSI *END* LINE 
 END3     POSTERR   SEV=ANSI,NR=E38 
  
*         POST NON-ANSI DIAGNOSTIC SUMMARIES. 
  
 END4     SA1    NACOM
          SB1    1
          ZR     X1,END5     IF NO NON-ANSI COMMENT LINES 
          CALL   CDD
          LX6    6
          POSTERR   SEV=ANSI,NR=E228,FMT=DPC,TXT=X6 
 END5     SA1    NABC 
          SB1    1
          ZR     X1,LEX      IF NO NON-ANSI BLANK LINES, EXIT...
          CALL   CDD
          LX6    6
          POSTERR   SEV=ANSI,NR=E208,FMT=DPC,TXT=X6,RETURN=LEX
 ERP      TITLE  ERP - COMMON ERROR PROCESSING. 
**        ERP - COMMON ERROR PROCESSING.
  
  
 ERP1     SA1    SBUFLG 
          NZ     X1,ERP1B    IF NEXT LINE ALREADY IN *SBUFF*
 ERP1A    RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          ZR     X1,ERP1A    IF LINE IS CONTINUED, STRIP... 
 ERP1B    POSTER SEV=FC,NR=28  *TABLES OVERLAP, INCREASE FL*
  
 ERP2     SA1    DTYPE
          ZR     X1,D.SCN52  IF NOT A DEBUG STATEMENT 
          DBGERR   (ILLEGAL FORM) 
          EQ     D.BADC 
  
 D.SCN52  SB6    -E29        ERR MSG NR - *UNRECOGNIZED STATEMENT*
          EQ        PROE
  
 ERP3     BX6    X6-X6
          SB6    -E175       ERR MSG NR - *BAD LOGICAL IF*
          SA6    LELIST 
          EQ     PROE 
  
 ERP4     SB6    E324        ERROR MSG NO. - UNRECOGNISED OPERATOR
          EQ     ERP5B
  
 ERP5     SB6    E297        ERROR MSG NO.-*INVALID USE OF CHAR STRING* 
 ERP5B    SA6    PAD         TEMP SAVE CHARACTER STRING 
          SA4    PAD
          MX6    0
          PX4    X4,B5       PACK UP CHARACTER STRING IN ELIST FORMAT 
          SA6    A4          TURN OFF PACK IN PROGRESS FLAG 
          SA1    EXPEXP 
          NZ     X1,ERP5A    IF RELATIONAL PACK IN PROGRESS 
          SB6    E32         ERR MSG NR - *NAME TOO LONG* 
 ERP5A    SA6    A1          TURN OFF RELATIONAL FLAG 
          EQ     PROE 
  
 ERP6     SB6    E37         ERR MSG NR - *ILLEGAL CHARACTER* 
          EQ     ERP20
  
 ERP7     SB6    E313        ERR MSG NR - *ILL SYNTAX AFTER KEYWORD*
          EQ     ERP20
  
 ERP8     SB6    -E111       ERR MSG NR - *ILL SYNTAX IN ASSIGN STMT* 
          EQ     PROE 
  
 ERP9     SB6    -E80        ERR MSG NR - *LAB REF HAS MORE THAN 5 DGTS*
          EQ     PROE 
  
 ERP10    RJ     SRCH        TRY TO TYPE STMT (RETURNS ONLY IF TYPED) 
          EQ     ERP7 
  
 ERP11    RJ     P$T         PROCESS $ TERMINATOR 
          EQ     ERP7 
  
 ERP12    SA1    EXPEXP 
          SB6    -E29        ERR MSG NR - *UNRECOGNIZED STATEMENT*
          ZR     X1,PROE     IF NOT PROCESSING RELATIONAL PACK
          MX4    0
          BX3    X6 
          SB6    E297        ERR MSG NR - *INVALID USE OF CHAR STRING*
          EQ     PROE 
  
 CERP     SB6    E209        ERR MSG NR - *LAST CHAR SEEN AFTER TROUBLE*
          EQ     CERPCOM
  
 CERP1    SB6    -E104       ERR MSG NR - *INCOMPLETE HOLL CONSTANT*
 CERPCOM  SA1    DTYPE       DEBUG STATEMENT TYPE 
          ZR     X1,ERP20    IF NOT A DEBUG STATEMENT 
          DBGERR   (BAD CONSTANT) 
 D.BADC   SX6    B0 
          SA6    CAD               SET CONSTANT FINISHED FLAG 
          SA6    EXPEXP            TURN OFF EXPECTING EXPONENT
          SA6    HANG.             TURN OFF HANG. 
          SA6    TYPE        STMT TYPE = *BAD DEBUG*
          EQ     NEXTS       STRIP CONTINUATION LINES 
  
 ERP20    SB7    1R 
          MX6    0
          BX7    X7-X7
          NE     B2,B7,ERP20A IF CHAR IS NOT *BLANK*
          SB2    1R"         REPLACE TRUE CHARACTER 
 ERP20A   SA6    CAD         CLEAR *CONSTANT PACK-IN-PROGRESS* FLAG 
          SA7    EXPEXP      CLEAR *HANGING EXPONENT* FLAG
          BX4    X4-X4
          SX3    B2 
          SA6    HANG.       CLEAR *HANGING PERIOD* FLAG
          LX3    48-6 
          SA7    PAD         CLEAR *PACK7 PACK-IN-PROGRESS* FLAG
          PL     B2,PROE     IF CHAR IS NOT *EOS* 
          SA3    =R.STMT-END. 
 PROE     SA1    DBGPHCT
          NZ     X1,PROE2    IF IN DEBUG *EXT. PACKET* PROCESSING 
          POSTER SEV=FE,NR=** 
 PROE2    SA1    SBUFLG 
          SX6    ST.BAD      SET STMT TYPE TO *BAD* 
          SA6    TYPE 
          NZ     X1,LEX      IF NEXT LINE ALREADY IN *SBUFF*
 NEXTS    RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          NZ     X1,NEWS     IF NEW STATEMENT FOUND 
          EQ     NEXTS       CONTINUE STRIPPING CONTINUATION CARDS
 FORMAT   TITLE  PROCESS FORMAT STATEMENT 
* FORMAT PACKS 10 CHARACTERS/WORD 
  
 FORMAT   SX6    B0+
          SA6    PARENS      TO AVOID UNBALANCED PARENS DIAGNOSTIC
          SA1    CONTCNT
          SA2    DUKE 
          SB1    1
          SB2    SBUFF
          IX6    X1+X2       NR OF CARD WHERE FORMAT BEGINS, FOR ERR MSG
          SA1    B2-B1       DUMMY READ TO INIT A1
          SA4    COLS 
          SB2    B2+X4       ADDR OF FIRST CHAR AFTER LEFT PAREN
          SA3    SELIST 
          SX7    -B1         'ERPRO' REQUIRES COL CNT INIT 1 LOW
          SA6    CD          STORE CARD NR FOR 'ERPRO'
          SB2    B2-B1       BACK ADDR UP TO LEFT PAREN 
  
*  DETERMINE COLUMN OF FORMAT LEFT PAREN FOR ERROR MSG COMPUTATION
  
 FORLOOP  SA1    A1+B1       GET NEXT CHARACTER 
          SB3    A1 
          UX6,B4 X1          UNPACK LEADING BLANK AND CHARACTER COUNT 
          SX7    X7+B4       SUM BLANK AND CHARACTER COUNT
          LT     B3,B2,FORLOOP IF NOT ADVAN TO COLUMN WITH LEFT PAREN 
          SA7    COL         STORE AS COLUMN COUNT FOR 'ERPRO'
          SB2    8*6         INITIALIZE PACKING SHIFT COUNT 
          SB3    6
          SX7    9
          SX5    1R          DPC BLANK
          LX6    9*6         LEFT JUSTIFY THE LEFT PAREN IN PACKING REG 
          SA7    TYPE        FORMAT STATEMENT TYPE IS 9 
  
*  ????   BEGIN 6600 IN-STACK LOOP
  
 FORMAT1  SA1    A1+B1       GET NEXT CHARACTER TO PACK 
          BX0    X5          BLANK FOR PACKING
          SX4    X4+B1       COLUMN COUNT + 1 
          UX2,B4 X1 
  
 FORMAT2  GT     B4,B1,FORMAT3  IF LEADING BLANK(S) TO INSERT 
          BX0    X2             CHARACTER FOR PACKING 
          MI     X2,FORMAT4     IF E-O-L SENTINEL 
          ZR     B4,FORMAT1     IF CHARACTER PACKED 
  
 FORMAT3  LX1    X0,B2       SHIFT CHAR/BLANK FOR PACKING 
          SB4    B4-B1       BLANK COUNT - 1
          SB2    B2-B3       PACKING SHIFT COUNT - 6
          BX6    X6+X1       PACK CHAR/BLANK
          PL     B2,FORMAT2  IF PACKING REGISTER NOT FULL 
          SA6    X3          STORE PACKING REGISTER 
          SB2    54          RESET PACKING SHIFT COUNT
          SX3    X3-1        DECR E-LIST STORE POINTER
          BX6    X6-X6       CLEAR PACK REGISTER
          EQ     FORMAT2
  
*  ''''   END IN-STACK LOOP 
  
 FORMAT4  BX7    X7-X7
          SA6    X3          LAST PACKED WORD TO E-LIST 
          SA7    A6-B1       STORE FORMAT LIST TERMINATOR 
          SX7    A7 
          SA7    ELAST       STORE LAST E-LIST ADDR USED
          RJ     SAV         SAVE PACKING REGISTERS 
          RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          NZ     X1,NEWS     IF NEW STATEMENT FOUND 
          RJ     RES         RESTORE PACKING REGISTERS
          SA1    SBUFF-1     DUMMY TO INITIALIZE A1 
          EQ     FORMAT1
 GET      SPACE  4,8
 GET2     SX7    A4-SBUFF+1 
          SA7    COLS        UPDATE COLUMN POINTER
  
 GET      SUBR               ** ENTRY/EXIT ** 
 GET1     SA3    COLS        NEXT COLUMN COUNTER
          SA4    X3+SBUFF    NEXT CHARACTER 
          MX5    -1R.        SHIFT TEST MASK FOR ILLEG CHARS 00B,60B_77B
          SB7    X4+7777B    BIAS ILLEGAL CHAR TO 7777B OR 10057B_10076B
          AX0    B7,X5       B7 IS TRANSFERRED TO SHIFT UNIT MODULO 64
          SB2    X4          PUT CHARACTER IN B2 FOR RETURN 
          NZ     X0,GET2     IF LEGAL CHARACTER 
          RJ     PGCOM       GO CHECK CHAR AND LOOK FOR CONTINUATION
          NZ     B4,GET1     IF NOT STARTING DELIMITED HOLLERITH STRING 
          EQ     GET2 
 HOLLRTH  TITLE  PROCESS HOLLERITH CONSTANT 
*** 
*         HOLLRTH - ENTER HOLLERITH CONSTANT IN 'ELIST' AND 'CONSTOR'.
* 
*         ON ENTRY - X6 = STRING LENGTH COUNT, LEFT-ADJ DPC, ZERO FILL. 
*                    B1 _ NEXT STATE. 
*                    B2 = <H>, <L> OR <R> IN DPC, RIGHT-ADJUSTED. 
* 
*         ON EXIT -  B1 _ NEXT STATE. 
*                    B5 = 1 
*                    ALL OTHER REGISTERS DESTROYED. 
* 
*         NORMAL EXIT - EQ BOSS 
*         ERROR EXITS - CERP1, ERP2 
* 
*         SUBROUTINES CALLED - PACKC,PACKT,SCNSAVE,RESTO,NEXT,ANSIERP 
* 
 HOLLRTH  SB5    1
          SA5    N           NR CHARAC IN COUNT STRING
          BX7    X7-X7       CLEAR BINARY ACCUMULATOR 
          LX6    6
          SX5    X5-10
          PL     X5,ERP2     IF TOO MANY CHARACTERS IN COUNT STRING 
          MX0    -6          1-CHARACTER MASK 
          BX4    X4-X4       CLEAR INTERMEDIATE HOLDING REGISTER
  
*  CONVERT DISPLAY CODED CHARACTER COUNT TO BINARY
  
 HOLL1    IX2    X7+X7       * 2
          LX7    3           * 8
          BX3    -X0*X6      NEW DIGIT
          IX2    X2+X7       * 10 
          LX6    6
          IX7    X2+X4       MERGE NEW DIGIT
          SX4    X3-1R0      DPC TO BINARY
          PL     X4,HOLL1    IF NOT END OF DPC COUNT STRING 
          SB6    X7 
  
*  PARTIALLY ASSEMBLE E-LIST ENTRY WORD FOR THE CONSTANT
  
          SX1    B2-B5       TRANSFORMS H=07, L=13, R=21
          ZR     B6,CERP1    IF ZERO-LENGTH HOLLERITH STRING
          AX1    3           FINAL HOLL CONSTANT TYPE CODE H=0,L=1,R=2
          SX0    -E197       ERR MSG NR - *NON-ANSI CONSTANT TYPE*
  
 HOLL2    SX2    6           E-LIST TYPE CODE FOR HOLLERITH CONSTANT
          LX1    51 
          BX7    X1+X2
          SA7    CTYPE       TEMP SAVE E-LIST ENTRY 
          ZR     X1,HOLL3    IF H(OLLERITH) TYPE STRING 
          RJ     ANSIERP     GO FILE NON-ANSI DIAGNOSTIC
  
*         INITIALIZE FOR PACKING LOOP.
  
 HOLL3    SB5    1
          SA3    COLS 
          SB4    1R"         (B4) = STRING DELIMITER
          MX6    0           (X6) = CONSTANT STRING PACKING REGISTER
          SB7    B0          (B7) = LEADING BLANK COUNT 
          SA4    X3+SBUFF-1  INITIALIZE CHARACTER FETCH POINTER 
          SX5    1R 
          SA6    N           CLEAR ACTUAL STRING LENGTH COUNTER 
  
*  GET NEXT STRING CHARACTER
  
 HOLL4    NZ     B7,HOLL5    IF CURRENT NON-BLANK CHARACTER NOT PACKED
          SA4    A4+B5       FETCH NEXT NON-BLANK CHARACTER 
          UX3,B7 X4          LEADING BLANK COUNT TO B7, NON-BLANK TO X3 
  
 HOLL5    SB2    X5          BLANK FOR PACK (IF NEEDED) 
          NE     B7,B5,HOLL6 IF LEADING BLANK(S) TO RESTORE 
          SB2    X3          NON-BLANK CHARACTER FOR PACK 
  
 HOLL6    MI     B2,HOLL9    IF E-O-L SENTINEL
          SB6    B6-B5       HOLLERITH STRING COUNT - 1 
          SB7    B7-B5       LEADING BLANK COUNT - 1
          PL     B6,HOLL7    IF NOT DELIMITED STRING
          SX0    B6+1 
          EQ     B2,B4,DELIM1   IF STRING DELIMITER < " > 
          ZR     X0,DELIM2   IF PREVIOUS CHAR WAS DELIM, END OF STRING
  
*  PACK CURRENT CHARACTER AND TEST FOR END-OF-STRING
  
 HOLL7    RJ     PACKC       GO PACK CURRENT CHARACTER
          NZ     B6,HOLL4    IF HOLL COUNT NOT EXHAUSTED
  
*  TERMINAL PROCESSING FOR NON-DELIMITED STRING 
  
          SX7    A4-SBUFF    RECONSTRUCT 'SBUFF' ORDINAL
          NZ     B7,HOLL8    IF CURRENT CHAR NOT PART OF HOLL STRING
          SX7    X7+1        ADV POINTER TO NEXT CHAR FOR 'COLS' UPDATE 
  
 HOLL8    SA7    COLS        UPDATE ORDINAL 
          RJ     PACKT       GO TERMINATE CONSTANT, MAKE E-LIST ENTRIES 
          SB5    1
          RJ     GET         GET NEXT CHARACTER 
          JP     B1          CONTINUE LEXICAL SCAN... 
  
*  END OF CARD ENCOUNTERED
  
 HOLL9    SX7    -1 
          SX0    B6 
 +        NZ     X0,*+1      IF NOT LOOKING FOR 2ND DELIMITER 
          SX7    *           SET P-I-P FLAG TO NON-HOLL (>0) TO AVOID 
*                              INCOMPLETE PACK ERR IF E-O-S ENCOUNTERED 
          SA7    CAD         SET PACK-IN-PROGRESS FLAG
          RJ     SAV         SAVE PACKING REGISTERS 
          RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          NZ     X1,NEWS     IF NEW STATEMENT FOUND 
          SB4    1R"
          RJ     RES         RESTORE PACKING REGISTERS
          SA4    SBUFF       INITIALIZE CHARACTER FETCH POINTER 
          SB5    1
          UX3,B7 X4 
          EQ     HOLL5
 DELIMH   SPACE  4,8
*  PROCESS DELIMITED HOLLERITH CONSTANT STRING
  
 DELIMH   SX0    -E259       ERR MSG NR 
          SX1    4           (X1) = AUX TYPE CODE FOR DELIM CONSTANT
          SB6    -1          SET *DELIM STRING* STATUS
          EQ     HOLL2
  
*  INTERMEDIATE PROCESSING FOR DELIMITED STRING 
  
 DELIM1   ZR     X0,HOLL7    IF 2ND CONSEC DELIMITER FOUND, GO PACK ONE 
          SB6    0           FLAG TO INDICATE ONE DELIMITER FOUND 
          EQ     HOLL4       GO LOOK FOR 2ND CONSEC DELIMITER 
  
*  TERMINAL PROCESSING FOR DELIMITED STRING 
  
 DELIM2   SA1    N           STRING LENGTH
          SX7    A4-SBUFF    RECONSTRUCT COLUMN POINTER 'COLS'
          NZ     X1,HOLL8    IF NOT ZERO-LENGTH STRING
          EQ     CERP1
 IMP      TITLE  IMP - IMPLICIT STATEMENT TYPE PROCESSOR
**        IMP - IMPLICIT STATEMENT TYPE PROCESSOR.
* 
*                THE *IMPLICIT* STATEMENT IS IRREGULAR IN ALLOWING THE
*         15-CHARACTER STRING *DOUBLEPRECISION* TO APPEAR IN NON-KEYWORD
*         POSITIONS.  SINCE *PACK7* CAN-T HANDLE A STRING THIS LONG,
*         *LEX8* TRAPPED IT AND CALLED *PACK30* INSTEAD.  *IMP* ERROR 
*         CHECKS THE STRING, TRUNCATES IT TO *DOUBLE*, FORMATS AND
*         STORES IT IN E-LIST.  OTHER, SHORTER STRINGS ARE JUST 
*         FORMATTED AND STORED.  *DECPRO/DPIMP* WILL CHECK THEM LATER.
* 
* 
*         ENTRY  (B5) = 1 
*                (B6) = TYPE KEYWORD STRING LENGTH (CHARACTERS) 
* 
*         EXIT   (B5) = 1 
*                (B6) = ADJUSTED LENGTH OF TYPE KEYWORD (CHARACTERS)
*                8 OR FEWER CHARACTERS ARE STORED IN E-LIST AT (ELAST), 
*                IN STANDARD VARIABLE NAME FORMAT.
* 
*         USES   X - 1, 2, 3, 6 
*                A - 1, 2, 3, 6 
*                B - 3, 6 
* 
*         CALLS  ELPUT. 
  
  
 IMP      SUBR               ** ENTRY/EXIT ** 
          SA1    KEYL 
          SA2    A1+B5       (X2) = KEYWORD CHARACTERS 1-10 
          UX1,B6 X1          (B6) = KEYWORD LENGTH (CHARACTERS) 
  
*         CHECK FOR *DOUBLEPRECISION* LENGTH AND CHARACTER MATCH. 
  
          SA3    =L*DOUBLEPRECISION*
          SA1    A2+B5       (X1) = KEYWORD CHARACTERS 11-20
          IX6    X2-X3
          NZ     X6,IMP2     IF MISMATCH
          SA3    A3+B5       (X3) = *ISION*, -L- FORMAT 
          IX6    X1-X3
          NZ     X6,IMP2     IF MISMATCH
          MX1    6*6
          BX2    X1*X2       TRUNCATE 1-10 TO *DOUBLE*
          SB6    6           NR CHARACTERS IN *DOUBLE*
  
*         CONVERT STRING TO E-LIST FORMAT (MAX 8 CHARS) AND STORE.
  
 IMP2     SB3    8
          LE     B6,B3,IMP3  IF LENGTH .LE. 8 
          SB6    8
 IMP3     SA1    FILL8R+B6   BLANK FILL 
          AX2    12 
          SX6    B0 
          PX3    X2,B5
          BX1    X3+X1       BLANK FILL 
          SA6    IMPFLG      CLEAR *IMPLICIT-IN-PROGRESS* FLAG
          ELPUT  X1 
          EQ     EXIT.
 LEX      TITLE  LEX - BEGIN LEXICAL SCAN OF STATEMENT. 
**        LEX - BEGIN LEXICAL SCAN OF STATEMENT.
* 
*                LEXICALLY SCANS AND GENERATES *ELIST* FOR A STATEMENT
*         BY CHAINING THROUGH THE *LEX-N-* ROUTINES. IF POSSIBLE, THE 
*         STATEMENT IS ALSO TYPED.
* 
*         ENTRY  INITIAL LINE OF STATEMENT IS BURST IN STRING BUFFER. 
* 
*         EXIT   (TYPE) = STATEMENT TYPE CODE.
*                (SELIST) = ADDR OF 1ST *ELIST* ELEMENT OF STATEMENT. 
*                (ELAST) = ADDR OF LAST *ELIST* ELEMENT OF STATEMENT. 
*                *ELIST* IS AN INVERTED TABLE GROWING FROM A HIGH CORE
*                ADDRESS TO A LOWER CORE ADDRESS. 
*                THEREFORE, (SELIST).GE.(ELAST).
* 
  
*         LEX TYPE DETERMINER.
* 
          CON    SCANNER1 
  
  
 LEX      ENTRY. *           ** ENTRY/EXIT ** 
          SA1    LELIST 
          SB5    1
          NZ     X1,LEX12    IF RESTARTING FOR OBJECT OF ONE-BRANCH *IF*
          RJ     GET         GET FIRST CHARACTER OF STMT
          SX7    1
          SA7    NULLSTMT    *NULL STATEMENT* FLAG OFF
          SB6    1R0
          SB7    1R$
          LT     B2,B6,LEX12 IF STMT BEGINS WITH ALPHABETIC 
          NE     B2,B7,ERP2  IF STMT DOES NOT BEGIN WITH $
          RJ     P$T         PROCESS $ TERMINATOR 
          EQ     SCANNER1    IGNORE NULL STMT 
  
 LEX12    SA1    DTYPE
          NZ     X1,LEX13    IF DEBUG STATEMENT 
  
          SA1    =XDFLAG
          AX1    1
          ZR     X1,LEX12B   IF INPUT FILE IS NOT EXTERNAL DEBUG FILE 
          SA1    SBUFLG 
          NZ     X1,LEX      IF NEXT LINE ALREADY IN *SBUFF*
  
 LEX12A   RJ     NXT         REQUEST AND PROCESS NEXT LINE
          ZR     X1,LEX12A   IF LINE CONTINUED, STRIP 
          EQ     LEX
  
 LEX12B   SB1    LEX2 
          RJ     PACK30      PACK 1ST 30 CHARS OF STMT
          EQ     LEX2        CONTINUE SCAN... 
  
 LEX13    CALL   ISITDBG     TRY TO TYPE DEBUG KEYWORD
          SA1    TYPE 
          SB1    LEX8        NEXT LEXICAL SCANNING ROUTINE
          NZ     X1,LEX8     IF TYPED, THEN CONTINUE SCAN...
          RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          NZ     X1,NEWS     IF NEW STATEMENT FOUND 
 LEX.1    RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          ZR     X1,LEX.1    IF NO NEW STATEMENT, STRIP CONTINUATION
          EQ     NEWS 
 LEX2     TITLE  LEX2 - ALPHANUMERIC FOLLOWED BY NON-ALPHANUMERIC.
*         LEX2 JUMP TABLE.
* 
 LJT2     JPC    ERP10       +
          JPC    ERP10       -
          JPC    LEX22       *
          JPC    LEX23       /
          JPC    LEX24,LP    (
          JPC    ERP10       )
          JPC    LEX24A      $
          JPC    LEX26,EQU   =
          JPC    LEX28       SPECIAL HOLLERITH STRING DELIMITER 
          JPC    LEX27       ,
          JPC    ERP10       .
  
*         LEX2 - ALPHANUMERIC FOLLOWED BY NON-ALPHANUMERIC. 
* 
 LEX2     TYPER  LEX25
          SA1    B2+LJT2-1R+
          SB3    X1 
          LX1    30 
          JP     B3 
  
*         LEX22 - ALPHANUMERIC FOLLOWED BY *
* 
 LEX22    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LABEL AND/OR VARIABLE FROM STRING 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX23 - ALPHANUMERIC FOLLOWED BY /
* 
 LEX23    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LABEL AND/OR VARIABLE 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX24 - ALPHANUMERIC FOLLOWED BY (
* 
 LEX24    SA2    NLABEL 
          SX6    1
          SB1    LEX3        RETURN ADDR
          SA6    PARENS      INITIALIZE PAREN COUNT 
          ZR     X2,ADD1     IF NOT LABELLED, THEN NOT *FORMAT* 
          SA2    =6LFORMAT
          SA3    KEYW 
          NO
          BX7    X2-X3
          ZR     X7,FORMAT   IF *FORMAT* STMT 
          EQ     ADD1 
  
*         LEX25 - ALPHANUMERIC FOLLOWED BY $ OR TERMINATED
*                 BY NEXT CARD. 
* 
 LEX24A   RJ     P$T         PROCESS $ TERMINATOR 
  
 LEX25    SRCH   LEX         TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LABEL AND/OR VARIABLE 
          EQ     LEX         DONE, SO EXIT... 
  
*         LEX26 - ALPHANUMERIC FOLLOWED BY =
* 
 LEX26    SX6    1
          SB1    LEX5        NEXT STATE 
          SA6    N.EQUAL     NR OF =
          EQ     ADD1 
  
*         LEX27 - ALPHANUMERIC FOLLOWED BY ,
* 
 LEX27    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LABEL AND/OR VARIABLE FROM STRING 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX28 - ALPHANUMERIC FOLLOWED BY DELIMITED HOLLERITH STRING.
* 
 LEX28    SB1    LEX29       RETURN ADDR
          EQ     DELIMH 
  
          CON    LEX25       AUXILIARY TYPE DETERMINER FOR
*                            *STOP*,*PAUSE* STMTS 
  
 LEX29    SB4    1R$
          EQ     B2,B4,LEX24A  IF STMT TERMINATED BY $
          EQ     ERP10
 LEX3     TITLE  LEX3 - SCANNING CONTINUES AFTER FIRST LEFT PARENTHESIS.
*         LEX3 JUMP TABLE.
* 
 LJT3     JPC    ADD1,PLUS   +
          JPC    ADD1,MINUS  -
          JPC    LEX83       *
          JPC    ADD1,SLASH  /
          JPC    LEX33,LP    (
          JPC    LEX34,RP    )
          JPC    ERP11       $
          JPC    LEX35,EQU   =
          JPC    DELIMH      SPECIAL HOLLERITH STRING DELIMITER 
          JPC    ADD1,COMMA  ,
          JPC    POINT       .
  
*         LEX3 - SCANNING CONTINUES AFTER FIRST LEFT PAREN. 
* 
 LEX3     TYPER  ERP10
          SB3    1R0
          LT     B2,B3,LEX32 IF ALPHABETIC
          SB3    1R+
          LT     B2,B3,DIGIT  IF NUMERIC, PACK CONSTANT 
          SA1    B2+LJT3-1R+
          SB3    X1 
          LX1    30 
          JP     B3 
  
*         LEX32 - ALHANUMERIC(...   FOLLOWED BY ALPHABETIC. 
* 
 LEX32    RJ     PACK7       PACK SYMBOLIC NAME AND STORE IN *ELIST*
          EQ     LEX3        CONTINUE SCAN... 
  
*         LEX33 - ALPHANUMERIC(...   FOLLOWED BY (
* 
 LEX33    SA2    PARENS 
          SX6    X2+1        PAREN COUNT+1
          SA6    A2 
          EQ     ADD1        MAKE ELIST ENTRY 
  
*         LEX34 - ALPHANUMERIC(...   FOLLOWED BY )
* 
 LEX34    SA2    PARENS 
          SX6    X2-1        PAREN COUNT-1
          SA6    PARENS 
          NZ     X6,ADD1     IF PAREN COUNT NOT ZERO
  
*         WHEN PAREN COUNT HAS GONE TO ZERO.
  
          SB1    LEX4        RETURN ADDR
          EQ     ADD1        MAKE *ELIST* ENTRY...
  
*         LEX35 - ALPHANUMERIC(...   FOLLOWED BY =
* 
 LEX35    SA5    N.EQUAL
          SX6    X5+1        NR EQUAL SIGNS+1 
          SA6    A5 
          EQ     ADD1        MAKE *ELIST* ENTRY...
 LEX4     TITLE  LEX4 - ALPHANUMERIC(...)     WHEN PAREN COUNT GOES TO Z
,ERO. 
*         LEX4 JUMP TABLE.
* 
 LJT4     JPC    LEX44       +
          JPC    LEX44       -
          JPC    ERP10       *
          JPC    LEX45       /
          JPC    LEX46       (
          JPC    ERP10       )
          JPC    LEX46A      $
          JPC    LEX48       =
          JPC    LEX410      SPECIAL HOLLERITH STRING DELIMITER 
          JPC    LEX49       ,
          JPC    LEX44       .
  
*         LEX4 - ALPHANUMERIC(...)     WHEN PAREN COUNT GOES TO ZERO. 
* 
 LEX4     TYPER  LEX47
          SB3    1R+
          LT     B2,B3,LEX42 IF ALPHANUMERIC
          SA1    B2+LJT4-1R+
          SB3    X1 
          LX1    30 
          JP     B3 
  
*         LEX42 - ALPHANUMERIC(...)   FOLLOWED BY ALPHANUMERIC. 
* 
 LEX42    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LEADING LABEL AND/OR VARIABLE 
          SA1    TYPE 
          SA2    LELIST 
          SB3    1R0
          SX7    X1-ST.LIF
          NZ     X7,LEX8     IF NOT *IF*, CONTINUE LEXICAL SCAN...
          GE     B2,B3,LEX43 IF STMT IS *IF(...)NUMERIC*
  
*         STMT IS *IF(...)ALPHABETIC*.
  
          NZ     X2,ERP3     IF STMT IS *IF(...)IF(...)NON-NUMERIC* 
          MX6    -1 
          NO
          SA6    LELIST      SET TO *NEED TO TYPE OBJECT OF LOGICAL IF* 
          EQ     LEX         EXIT...
  
*         STMT IS *IF(...)NUMERIC*. 
  
 LEX43    SX6    16 
          SA6    TYPE 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX44 - ALPHANUMERIC(...)   FOLLOWED BY . + - 
* 
 LEX44    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX45 - ALPHANUMERIC(...)   FOLLOWED BY / 
* 
 LEX45    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE VARIABLE AND STORE IN *ELIST* 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX46 - ALPHANUMERIC(...)   FOLLOWED BY ( 
* 
 LEX46    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE VARIABLE AND STORE IN *ELIST* 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX47 - ALPHANUMERIC(...)   FOLLOWED BY $ OR TERMINATED 
*                 BY NEXT CARD. 
* 
 LEX46A   RJ     P$T         PROCESS $ TERMINATOR 
  
 LEX47    SRCH   LEX         TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE VARIABLE AND STORE IN *ELIST* 
          EQ     LEX         DONE, SO EXIT... 
  
*         LEX48 - ALPHANUMERIC(...)   FOLLOWED BY = 
*               - TYPE IS   F(...)=   OR   V=C
* 
 LEX48    SX6    12          ASF OR REPLACEMENT 
          SB1    LEX8        ERROR RETURN ADDR
          SA6    TYPE 
          RJ     ADJ         MAKE *ELIST* ENTRY FOR *F* OR *V*
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX49 - ALPHANUMERIC(...)   FOLLOWED BY , 
* 
 LEX49    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN STMT
          RJ     ADJ         REMOVE LEADING LABEL AND/OR VARIABLE 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX410 - ALPHANUMERIC(...)   FOLLOWED BY SPECIAL HOLLERITH
*                 STRING DELIMITER. 
* 
 LEX410   SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
 LEX5     TITLE  LEX5 - SCANNING CONTINUES AFTER =
*         LEX5 JUMP TABLE.
* 
 LJT5     JPC    LEX54       +
          JPC    LEX54       -
          JPC    ERP10       *
          JPC    ERP10       /
          JPC    LEX54       (
          JPC    ERP10       )
          JPC    ERP11       $
          JPC    ERP10       =
          JPC    LEX55       SPECIAL HOLLERITH STRING DELIMITER 
          JPC    ERP10       ,
          JPC    LEX54       .
  
*         LEX5 - SCANNING CONTINUES AFTER = 
* 
 LEX5     TYPER  ERP10
          SB3    1R0
          LT     B2,B3,LEX52  IF ALPHABETIC 
          SB3    1R+
          LT     B2,B3,LEX53  IF NUMERIC
          SA1    B2+LJT5-1R+
          SB3    X1 
          JP     B3 
  
*         LEX52 -  =  FOLLOWED BY ALPHABETIC. 
* 
 LEX52    SB1    LEX6        ERROR RETURN 
          RJ     PACK7       PACK SYMBOLIC NAME AND STORE IN ELIST
          EQ     LEX6        CONTINUE LEXICAL SCAN... 
  
*         LEX53 -  =  FOLLOWED BY NUMERIC.
* 
 LEX53    SB1    LEX7        RETURN ADDR
          EQ     DIGIT       PACK CONSTANT AND MAKE *CONSTOR* ENTRY 
  
*         LEX54 - TYPE IS *V=E*.
* 
 LEX54    SX7    ST.V=E 
          SB1    LEX8        ERROR RETURN 
          SA7    TYPE 
          RJ     ADJ         MAKE *ELIST* ENTRY FOR *V* 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
  
*         LEX55 -  =  FOLLOWED BY DELIMITED HOLLERITH CONSTANT. 
* 
 LEX55    SB1    LEX7        RETURN ADDR
          EQ     DELIMH 
 LEX6     TITLE  LEX6 - ...=ALPHANUMERIC   FOLLOWED BY NON-ALPHANUMERIC.
*         LEX6 JUMP TABLE.
* 
 LJT6     JPC    LEX54       +
          JPC    LEX54       -
          JPC    LEX54       *
          JPC    LEX54       /
          JPC    LEX54       (
          JPC    ERP10       )
          JPC    LEX61       $
          JPC    LEX54       =
          JPC    ERP10       SPECIAL HOLLERITH STRING DELIMITER 
          JPC    LEX63       ,
          JPC    LEX54       .
  
*         LEX6 -  ...=ALPHANUMERIC   FOLLOWED BY NON-ALPHANUMERIC 
* 
 LEX6     TYPER  LEX62
          SA1    B2+LJT6-1R+
          SB3    X1 
          LX1    30 
          JP     B3 
  
*         LEX62 - *V=E* FOLLOWED BY $ OR TERMINATED BY NEXT CARD. 
* 
 LEX61    RJ     P$T         PROCESS $ TERMINATOR 
 LEX62    SX7    12          *V=E*
          SB0    46000B 
          SA7    TYPE 
          RJ     ADJ         MAKE *ELIST* ENTRY FOR *V* 
          SB3    1R$
          NE     B2,B3,LEX   IF NEW STMT ON NEXT CARD, EXIT...
          SX7    1R$
          SA7    REG=B2 
          EQ     NEWS 
  
*         LEX63 - ALPHANUMERIC=ALPHANUMERIC  FOLLOWED BY ,
* 
 LEX63    SRCH   LEX8        TRY TO TYPE STMT 
          LX0    B4,X1
          PL     X0,ERP7     IF ILL SYNTAX IN KEYWORD 
          RJ     ADJ         REMOVE LABEL AND/OR VARIABLE FROM STRING 
          EQ     LEX8        CONTINUE LEXICAL SCAN... 
 LEX7     TITLE  LEX7 - ...=CONSTANT   FOLLOWED BY NON-ALPHANUMERIC.
*         LEX7  JUMP TABLE. 
* 
 LJT7     JPC    LEX54       +
          JPC    LEX54       -
          JPC    LEX54       *
          JPC    LEX54       /
          JPC    LEX54       (
          JPC    ERP10       )
          JPC    LEX61       $
          JPC    ERP10       =
          JPC    ERP10       SPECIAL HOLLERITH STRING DELIMITER 
          JPC    LEX63       ,
          JPC    LEX54       .
  
*         LEX7  -  ...=CONSTANT   FOLLOWED BY NON-ALPHANUMERIC
*              OR  ...=DELIMITED HOLLERITH STRING  FOLLOWED BY ANYTHING.
* 
 LEX7     TYPER  LEX62
          SA1    RELFLAG
          ZR     X1,LEX72    IF NOT *CONSTANT* FOLLOWED BY *RELATIONAL* 
          BX7    X7-X7
          SA7    A1          TURN OFF *RELFLAG* 
          EQ     LEX54       TYPE IS *V=E*
  
 LEX72    SB7    1R+
          LT     B2,B7,ERP2  IF ALPHANUMERIC AFTER DELIMITED HOLL STR 
          SA1    B2+LJT7-1R+
          SB1    LEX8        NEXT *LEX-N-* ROUTINE
          SB3    X1 
          LX1    30 
          JP     B3 
 LEX8     TITLE  LEX8 - STRAIGHT TRANSFORMATION.
*         LEX8 JUMP TABLE.
* 
 LJT8     JPC    ADD1,PLUS   +
          JPC    ADD1,MINUS  -
          JPC    LEX83       *
          JPC    ADD1,SLASH  /
          JPC    LEX33,LP    (
          JPC    LEX82,RP    )
          JPC    LEX89       $
          JPC    LEX35,EQU   =
          JPC    DELIMH      SPECIAL HOLLERITH STRING DELIMITER 
          JPC    ADD1,COMMA  ,
          JPC    POINT       .
  
*         LEX8 - STRAIGHT TRANSFORMATION. 
* 
 LEX8     TYPER  LEX
          SB3    1R0
          LT     B2,B3,LEX85 IF ALPHABETIC
          SB3    1R+
          LT     B2,B3,DIGIT IF NUMERIC 
          SA1    B2+LJT8-1R+
          SB3    X1 
          LX1    30          (X1)=30/(B3),30/*ELIST* ELEMENT ADDR 
          JP     B3 
  
*         LEX82 - ) 
* 
 LEX82    SA2    PARENS 
          SX6    X2-1        PAREN COUNT - 1
          SA6    A2+
          EQ     ADD1        MAKE ELIST ENTRY 
  
*         LEX83 - * 
* 
 LEX83    ELPUT  STAR        MAKE *ELIST* ENTRY 
          RJ     GET         GET NEXT CHARACTER 
          SA1    ELAST
          SB3    1R*
          EQ     B2,B3,LEX84 IF EXPONENTIAL  **  OPERATOR 
          JP     B1          CONTINUE LEXICAL SCAN... 
  
*         LEX84 - **
* 
 LEX84    SX6    X1+1        LOGICALLY ERASE 1ST  * 
          SX1    DSTAR
          SA6    A1 
          EQ     ADD1        MAKE ELIST ENTRY 
  
*         LEX85 - ALPHABETIC
* 
 LEX85    SA1    TYPE 
          SB4    X1-3 
          ZR     B4,LEX88    IF *IMPLICIT* STMT 
 LEX86    RJ     PACK7       PACK NAME AND STORE IN *ELIST* 
 LEX87    SA1    DTYPE
          SA2    TYPE 
          ZR     X1,LEX8     IF NOT A *DEBUG* STMT
          NZ     X2,LEX8     IF A LEGAL NAME
          DBGERR  (VARIABLE TOO LONG) 
          EQ     D.BADC      EXIT TO ERROR PROCESSOR
  
*         SPECIAL-CASE *IMPLICIT* STATEMENT. WE CAN-T USE *PACK7*,
*         BECAUSE THE STMT MAY CONTAIN *DOUBLEPRECISION*, WHICH IS 15 
*         CHARACTERS LONG.  USE *PACK30* INSTEAD. 
  
 LEX88    SA1    PARENS 
          MX6    1
          NZ     X1,LEX86    IF INSIDE PAREN NEST (D.P. IMPOSSIBLE) 
          SA6    IMPFLG      *IMPLICIT PACK* FLAG ON
          RJ     PACK30      PACK LONG TYPE KEYWORD 
          RJ     IMP         FORMAT AND (RE)STORE TYPE IN *ELIST* 
          EQ     LEX87       REJOIN NORMAL PROCESSING FLOW
*         LEX89 - $ 
* 
 LEX89    RJ     P$T         PROCESS $ TERMINATOR 
          SX7    1R$
          SA7    REG=B2 
          EQ     NEWS 
 LSL      SPACE  4,8
**        LSL - LIST SAVED LINES. 
* 
*                LISTS SOURCE LINES PREVIOUSLY SAVED IN A DEFERRED
*         LISTING BUFFER. 
* 
*         ENTRY  (DLBUF) = SAVED LINES, FORMATTED FOR LISTING.
*                (L.SL) = TOTAL LENGTH IN WORDS OF SAVED LINES. 
* 
*         EXIT   LINES LISTED.
*                (IEF) = 0
*                (L.SL) = 0 
*                (B1) = 1 
*                (B5) = 1 
* 
*         USES   X - 1, 6, 7
*                A - 1, 6 
*                B - 1, 2, 5, 6, 7
* 
*         CALLS  LISTL
  
  
 LSL      SUBR   =           ** ENTRY/EXIT ** 
          SA1    L.SL 
          SB1    1
          MX6    0
          SB6    DLBUF       (B6) = FWA OF NEXT LINE TO BE LISTED 
          SB5    B1 
          SB2    X1+         (B2) = TOTAL LENGTH OF REMAINING LINES 
          SA6    IEF         *BEFORE HEADER* FLAG OFF 
 LSL2     ZR     B2,EXIT.    IF NO MORE TO LIST 
          SA1    B6          (X1) = FIRST WORD OF LINE
          MX6    -12
 LSL3     BX7    -X6*X1 
          SA1    A1+B1
          NZ     X7,LSL3     IF NOT ZERO BYTE LINE TERMINATOR 
          SB7    A1-B6       (B7) = LINE LENGTH (WORDS) 
          SX7    A1          (X7) = FWA NEXT LINE 
          SX6    B2-B7       (X6) = TOTAL LENGTH OF REMAINING LINES 
          LX7    18D
          BX6    X7+X6
          NO
          SA6    L.SL        TEMP SAVE NEXT FWA, LENGTH 
          LISTL  B6,B7       ONE LINE TO -OUTPUT- 
          SA1    L.SL        RESTORE REGISTERS
          MX6    0
          SB5    B1 
          SB2    X1 
          AX1    18D
          SB6    X1 
          SA6    A1 
          EQ     LSL2        LOOP FOR NEXT LINE 
  
  
  
 L.SL     BSSZ   1           ON ENTRY TO *LSL*, TOTAL STMT LEN (WORDS). 
*                            *LSL* USES *L.SL* TO SAVE NEW FWA AND LEN. 
 MCE      SPACE  4,8
**        MCE - MAKE *CONSTOR* ENTRY. 
* 
*         ENTRY  (X6) = DPC *CONSTOR* ENTRY, LEFT JUSTIFIED, BLANK FILL 
* 
*         USES   X - 1,6,7
*                A - 1,6,7
*                B - 3
*         CALLS  PROE 
* 
  
 MCE      SUBR               ** ENTRY/EXIT ** 
          SA1    CCSTO       (X1)=ADDR OF NEXT AVAIL *CONSTOR* LOC
          SX7    X1+1 
          SA6    X1          MAKE *CONSTOR* ENTRY 
          SB3    X1-CONSTOR-CONSTORS+1
          SA7    A1 
          MI     B3,EXIT.    IF TABLE OVERFLOW NOT IMPENDING
          POSTER SEV=FE,NR=E289,RETURN=PROE2   *CONSTOR OVERFLOW* 
 NEWS     TITLE  NEWS - NEW STATEMENT FOUND.
**        NEWS - NEW STATEMENT FOUND. 
* 
  
  
 NEWS     BSS    0           ** ENTRY **
          SA1    SBUFLG 
          SX0    1
          BX7    X7-X7
          AX1    59          (X1) = -0 IF STMT TERMINATED BY $
*                                 = +0 IF STMT TERMINATED BY NEXT STMT
          BX6    X0-X1       (X6) = -1 IF STMT TERMINATED BY $
*                                 = +1 IF STMT TERMINATED BY NEXT STMT
          SA6    A1 
          RJ     RES         RESTORE INTERUPTED PACK REGISTERS
  
          SA2    PAD
          SA3    CAD
          SA4    IMPFLG 
          SA5    HANG.
  
          NZ     X2,NEWS3    IF AN INTERUPTED *PACK7* PACK
          MI     X3,CERP1    IF INCOMPLETE HOLLERITH CONSTANT PACK
          NZ     X3,NEWS4    IF AN INTERUPTED CONSTANT PACK 
          NZ     X4,NEWS6    IF PROCESSING *IMPLICIT* TYPE KEYWORD
          NZ     X5,ERP12    IF A HANGING PERIOD
  
 NEWS2    RJ     RES         (RE) RESTORE INTERUPTED PACKING REGISTERS
          SA1    =XFEFLAG 
          SA2    NULLSTMT 
          SA3    CLABEL 
          SA4    TYPE 
          NZ     X1,LEX      IF FATAL TO EXECUTION ERROR FOUND, EXIT... 
          ZR     X2,NEWS7    IF EMPTY STATEMENT 
          PL     X4,LEX      IF STATEMENT HAS ALREADY BEEN TYPED,EXIT...
          SA5    B1-1 
          SB4    X5          (B4)=ADDR OF *LEX-N-* TYPER FOR THIS KEYWRD
          JP     B4 
  
*         HERE IF INTERUPTED *PACK7* PACK.
  
 NEWS3    SA1    EXPEXP 
          ZR     X6,NEWS2    IF PACKING REGISTER EMPTY, NOTHING TO STORE
          NZ     X1,ERP12    IF INCOMPLETE RELATIONAL PACK
          RJ     PVN         PROCESS VARIABLE NAME
          ZR     X6,NEWS8    IF NAME TOO LONG IN C$ DEBUG STATEMENT 
          ELPUT  X6          MAKE *ELIST* ENTRY 
          EQ     NEWS2       REJOIN NORMAL FLOW...
  
*         HERE IF INTERUPTED CONSTANT PACK. 
  
 NEWS4    SA1    EXPEXP 
          SA2    HANG.
          NZ     X1,ERP12    IF HANGING EXPONENT
          ZR     X2,NEWS5    IF NO HANGING PERIOD 
          SA7    A1+         CLEAR *HANGING PERIOD* FLAG
          SB2    1R.
          RJ     PACKC       ADD . TO CONSTANT
          SX7    2
          SA7    CTYPE       CONSTANT TYPE = REAL 
 NEWS5    RJ     PACKT       TERMINATE THE CONSTANT PACK
          EQ     NEWS2       REJOIN NORMAL FLOW...
  
*         HERE IF PROCESSING *IMPLICIT* TYPE KEYWORD. 
  
 NEWS6    RJ     IMP         FORMAT AND (RE)STORE TYPE IN ELIST 
          EQ     NEWS2       REJOIN NORMAL FLOW...
  
*         HERE IF EMPTY STATEMENT.
  
 NEWS7    NZ     X3,ERP2     IF EMPTY STMT CONTAINS A VALID LABEL 
          SA1    =XDFLAG
          AX1    1
          ZR     X1,SCANNER1  IF NOT PROCESSING DBG EXT PACKET FILE 
          EQ     LEX
  
*         HERE IF NAME TOO LONG (.GT. 7 CHARS) IN C$ DEBUG STATEMENT. 
  
 NEWS8    SA6    TYPE        SET TO *BAD DEBUG STATEMENT* 
          DBGERR (KEYWORD OR VARIABLE TOO LONG.)
          EQ     LEX         EXIT...
 NEXT     TITLE  REQUEST NEXT SOURCE CARD 
 NXT      TITLE  NXT - REQUEST AND PROCESS NEXT SOURCE LINE.
**        NXT - REQUEST AND PROCESS NEXT SOURCE LINE. 
* 
*                TASKS PERFORMED -- 
*         1) CALLS *RNC* TO READ NEXT LINE FROM INPUT INTO (CP.CARD)
*              ET SEQ.
*         2) CALLS *CBL* TO CLASSIFY AND BURST LINE AT (CP.CARD) ET SEQ.
*         3A) IF A BLANK OR COMMENT LINE, CALLS *PBC* TO PROCESS IT AND 
*               *PLR* TO LIST IT. 
*          B) IF A CONTINUATION LINE, CALLS *PLR* TO LIST IT. 
*          C) IF AN EOR/EOF IS ENCOUNTERED ON INPUT FILE, PLACES THE
*               CHARACTERS *END ABSENT* INTO (CP.CARD) AND CALLS *CBL*
*               TO CLASSIFY AND BURST IT. 
* 
*         ENTRY  NONE 
* 
*         EXIT   NEW LINE CLASSIFIED AND BURST. 
*                (X1) = .NZ. IF A NEW STATEMENT WAS FOUND 
*                     = .ZR. IF A CONTINUATION OF CURRENT STATEMENT 
*                              WAS FOUND
* 
*         USES   ALL
* 
*         CALLS  CBL,D.IDSP,PBC,PLR,POSTER,RNC
* 
* 
  
  
 NXT      SUBR               ** ENTRY/EXIT ** 
 NXT2     SB1    1
          RJ     RNC         READ NEXT CARD 
          SX6    X7+2 
          SA6    L.PLINE
          NZ     X1,NXT6     IF INPUT FILE EMPTY
 NXT3     RJ     CBL         CLASSIFY AND BURST LINE
          NZ     X5,NXT4     IF COMMENT 
          NZ     X2,NXT5     IF CONTINUATION
  
*         HERE IF INITIAL LINE. 
  
          PL     X1,NXT8     IF COLUMNS 7-72 NOT BLANK
          NZ     X4,NXT8     IF LABELLED
  
*         HERE IF BLANK OR COMMENT. 
  
 NXT4     RJ     PBC         PROCESS BLANK OR COMMENT 
          RJ     PLR         PROCESS LISTING REQUEST
          EQ     NXT2        LOOP FOR NEXT LINE 
  
*         HERE IF CONTINUATION. 
  
 NXT5     RJ     PLR         PROCESS LISTING REQUEST
          SA1    CONTCNT
          SB7    X1-20
          PL     B7,NXT9     IF MORE THAN 19 CONTINUATION LINES 
          SA1    DFLAG
          ZR     X1,NXT5A    IF DEBUG OPTION NOT SELECTED 
          CALL   D.IDSP      SAVE UPDATE IDENT
 NXT5A    SA1    BLNKSTMT 
          SA2    =XFEFLAG 
          NZ     X2,NXT2     IF FATAL ERROR OCCURRED, STRIP CONTINUATION
          ZR     X1,EXIT.    IF PRIOR LINE(S) OF THIS STMT NON-BLANK
*                            (MAY BE PACKING A HOLLERITH STRING). 
          SA1    SBUFF
          MI     X1,NXT2     IF COLUMNS 7-72 BLANK
  
*         HERE IF NON-BLANK CONTINUATION LINE FOLLOWS BLANK INITIAL 
*         LINE.  UNDO *PBC*-S REVERSE CLABEL-TO-NLABEL TRANSFER.
  
          MX6    0
          SA6    NLABEL 
          EQ     NXT8        PROCESS AS INITIAL LINE
  
*         HERE IF INPUT FILE EMPTY. 
  
 NXT6     SA1    =XDFLAG
          AX1    1
          NZ     X1,NXT7     IF INPUT FILE = EXTERNAL DEBUG FILE
          SA1    ENDL        INVENT *END* LINE
          SA2    A1+B1
          BX6    X1 
          LX7    X2 
          SA6    =XCP.CARD
          SA7    A6+B1
          BX6    X6-X6
          SA6    A7+B1       MARK FULL WORD EOL 
          SB2    B1+B1
          SX6    B2+B1       (X6) = NR OF WORDS IN LINE = 3 
          SX7    X6+B2       (X7) = NR OF WORDS IN PRINT LINE = 5 
          SA6    L.CARD 
          SA7    L.PLINE
          SX6    ST.INV-ST.END
          SA6    NOEND       SET *END MISSING*
          EQ     NXT3        GO PROCESS INVENTED *END*
  
 NXT7     MX6    1
          SX7    B0 
          SA6    IEF         RESET *INITIAL ENTRY* STATUS FOR MAIN PROG 
          SA7    C$STMT 
  
*         HERE IF NEW STATEMENT FOUND.
  
 NXT8     SX1    B1          SET TO *NEW STATEMENT FOUND* 
          EQ     EXIT.
  
*         HERE IF MORE THAN 19 CONTINUATION LINES -- ERROR. 
  
 NXT9     SB7    B7-B1
          SA1    C$STMT 
          MX6    0
          PL     B7,NXT2     IF ERROR MSG ALREADY ISSUED
          NZ     X1,NXT10    IF ERROR WAS IN C$-DEBUG STATEMENT 
          SX6    ST.BAD 
          SA6    TYPE        SET TO *BAD STATEMENT* 
          POSTER SEV=FE,NR=E31,RETURN=NXT2  *STATEMENT TOO LONG*
  
 NXT10    SA6    TYPE        SET TO *BAD C$-DEBUG STATEMENT*
          DBGERR (TOO MANY CONTINUATION LINES.) 
          EQ     NXT2 
 PACKC    SPACE  4,8
*** 
*         PACKC - PACKS TEN DPC CHARACTERS PER WORD AND STORES IT 
*                 IN 'CONSTOR'. 
* 
*                ONE CHARACTER IS PASSED IN B2 TO 'PACKC' PER RJ CALL.
*                SUCCESSIVE CHARACTERS ARE PACKED IN X6, LEFT TO RIGHT. 
*                WHEN A FULL WORD OF TEN CHARACTERS HAS ACCUMULATED IN
*                X6, 'PACKC' CALLS 'CKCSTOR' TO ENTER THE WORD IN 
*                'CONSTOR'. 
* 
*  ON ENTRY - B2 = NEW CHARACTER TO PACK
*             B3 = PACKING SHIFT COUNT
*             X6 = PACKING REGISTER 
* 
*  ON EXIT  - B3 AND X6 ARE UPDATED 
* 
*         REGISTERS ALTERED (INCLUDING CALLS TO 'CKCSTOR') -
*                X0,X1,X2,   X5,X6,X7 
*                   A1,A2,   A5,A6,A7 
*                         B3
* 
 PACKC    EQ     *+1S17      ENTRY/EXIT 
          SA1       N         STRING LENGTH 
          SA2    CCSTO       NEXT VACANT LOCATION IN 'CONSTOR'
          NZ     X1,NOTF      JUMP IF STRING ALREADY STARTED
          SB3       54        INITIALIZE FOR NEW STRING, SHIFT COUNT
          BX7    X2 
          MX6    0           CLEAR PACKING REGISTER 
          SA7       LOCC      POINTER FOR E-LIST ENTRY
  
 NOTF     SX0    B2           CHARACTER TO X0 
          SX7    X1+1         NEW CHARACTER COUNT 
          LX0    X0,B3
          BX6    X6+X0        OR INTO STRING
          SB3    B3-6         NEXT SHIFT COUNT
          SA7    A1           STORE IN N
          PL     B3,PACKC     RETURN
          RJ     MCE         MAKE *CONSTOR* ENTRY 
          SX6    0           CLEAR PACKING REGISTER 
          SB3       54
          EQ        PACKC     READY FOR NEXT CHARACTER
 PACKT    TITLE  BLANK FILL LAST WORD AND STORE IN E-LIST 
* PACKT FILLS LAST WORD WITH BLANKS, MAKES E-LIST ENTRY 
  
 PACKT    EQ     *+1S17      ENTRY/EXIT 
          SA1       LOCC      POINTER FOR E-LIST ENTRY
          SA2       CTYPE     CONSTANT TYPE 
          SA3    N
          BX7    X7-X7
          LX2    45 
          SA7    A3 
          BX1    X1+X2
          LX3    18 
          IX2    X1+X3
          SA7    CAD         PACK-IN-PROGRESS FLAG -OFF-
          SB7    54 
          PX7    X2,B0       12/2000B,3/TYPE,9/0,18/LEN,18/*CONSTOR* LOC
          MX0    1
          SA1    =10H              10 BLANKS FOR FILL 
          SA7    COMMON 
          EQ     B3,B7,PKT2  IF PACKING REGISTER IS EMPTY 
  
*         BLANK FILL AND STORE THE FINAL WORD OF THE STRING.
  
          SB3    B3-54+1     - (LENGTH OF FILL MASK COMPLEMENT) + 1 
          LX0    X0,B3       BECOMES RIGHT SHIFT SINCE B3 IS NEGATIVE 
          BX1    -X0*X1 
          IX6    X6+X1       MERGE STRING AND BLANK FILL
          RJ     MCE         MAKE *CONSTOR* ENTRY 
  
 PKT2     ELPUT  COMMON 
          EQ        PACKT 
 PACK30   TITLE  PACK SYMBOLIC IDENT (30 CHARAC) AND STORE IN E-LIST
 PACK30.1 SX6    A4-SBUFF 
          SA6    COLS        UPDATE POINTER TO NEXT COLUMN
  
 PACK30   SUBR               ** ENTRY/EXIT ** 
          SA3    COLS        GET NEXT COLUMN NUMBER 
          SB5    1
          SA4    X3+SBUFF    GET NEXT COLUMN
          BX6    X6-X6       CLEAR PACKING REGISTER 
          SX1    B2 
          MX3    -1R.        SHIFT TEST MASK FOR ILLEG CHARS 00B,60B_77B
          SB6    B0          (B6) = KEYWORD STRING LENGTH 
          SA6    KEYL        INITIALIZE KEYWORD LENGTH = 0
          SB3    54          INITIALIZE PACKING SHIFT COUNTER 
          SB4    7777B+1R+
          SA0    -6 
  
*  ????   BEGIN 6600 IN-STACK LOOP
  
 PACK30.2 LX2    B3,X1       SHIFT CHARACTER FOR PACKING
          SB6    B6+B5       STRING LENGTH + 1
          SB3    A0+B3       PACKING SHIFT COUNT - 6
          BX6    X6+X2       PACK THE CHARACTER 
 PACK30.3 MI     B3,PACK30.4 IF PACKING REGISTER FULL 
          SB7    X4+7777B    BIAS ILLEGAL CHAR TO 7777B OR 10057B_10076B
          AX0    B7,X3       B7 IS TRANSFERRED TO SHIFT UNIT MODULO 64
          SX1    X4          STRIP EXPONENT FOR PACKING 
          ZR     X0,PACK30.4 IF ILLEGAL CHARACTER OR END-OF-LINE
          SA4    A4+1        GET NEXT CHARACTER 
          LT     B7,B4,PACK30.2 IF NOT STRING TERMINATING CHARACTER 
  
*  ''''   END IN-STACK LOOP 
  
 PACK30.4 SB2    30 
          SA2    KEYL 
          GT     B6,B2,ERP2  IF KEYWORD LONGER THAN 30 CHARACTERS 
          SX2    X2+B5
          PX7    X2,B6       12/2000B + NR CHARACTERS, 48/NR WORDS
          SA6    KEYW-1+X2   PACKING REGISTER TO KEYWORD BUFFER 
          SB2    X1          (B2) = KEYWORD TERMINATOR
          SA7    A2          UPDATE LENGTHS 
          MX7    0
          SA7    A6+B5
          ZR     X0,PACK30.5 IF ILLEGAL CHARACTER OR END-OF-LINE
          GE     B7,B4,PACK30.1  IF STRING TERMINATING CHARACTER FOUND
          SB3    54          RESET PACKING SHIFT COUNTER
          SX6    0           CLEAR PACKING REGISTER 
          EQ     PACK30.3 
  
 PACK30.5 SB7    3
          NE     B6,B7,PACK30.6    IF KEYWORD NOT 3 CHARACTERS LONG 
          SA1    =3LEND 
          SA5    CONTCNT
          SB4    LEX8 
          BX2    X6-X1
          NZ     X2,PACK30.6 IF KEYWORD NOT *END* 
          SA1    LTYPE
          NZ     X5,PACK30.6 IF CONTINUATION LINE 
          EQ     B1,B4,PACK30.6    IF CALLED FROM *LEX8*
          NZ     X1,PACK30.6 IF *END* IS OBJECT OF A LOGICAL *IF* 
          MI     B2,ENDP     IF KEYWORD TERMINATED BY E-O-L SENTINEL
          SA1    NOEND
          NZ     X1,ENDP     IF *END* WAS INVENTED
 PACK30.6 RJ     PGCOM
          SA5    KEYL 
          SA0    -6 
          MX2    -1 
          IX7    X5+X2
          SA7    A5          BACK UP KEYWORD BUFFER POINTER 
          NZ     B4,PACK30.3 IF NOT STARTING DELIMITED HOLLERITH STRING 
          SA4    A4+1        ADVANCE COLUMN POINTER 
          EQ     PACK30.1 
 PACK7    TITLE  PACK SYMBOLIC NAME (7 CHARAC) AND STORE IN E-LIST
 PACK7.1  SA2    ELAST
          SA3    FWAWORK
          SX7    X2-1        INCREMENT INVERTED E-LIST POINTER
          IX2    X3-X7
          SA7    A2          UPDATE E-LIST POINTER
          PL     X2,ERP1     IF E-LIST SPACE FULL 
          SA6    X7          PACKED NAME TO E-LIST
 PACK7.2  SX6    B0+
          SA6    PAD         TURN PACK IN PROGRESS FLAG OFF 
  
 PACK7    SUBR   =           ** ENTRY/EXIT ** 
          SA3    COLS        GET NEXT COLUMN NUMBER 
          SB5    1
          SA4    X3+SBUFF    GET NEXT COLUMN
          SX7    B5 
          BX6    X6-X6       CLEAR PACKING REGISTER 
          SA7    PAD         SET FLAG TO *PACK7-IN-PROGRESS*
          SX1    B2 
          MX3    -1R.        SHIFT TEST MASK FOR ILLEG CHARS 00B,60B_77B
          SB3    42          INITIALIZE PACKING SHIFT COUNTER 
          SB4    7777B+1R+
          SB6    0           INITIALIZE STRING LENGTH COUNTER 
          SA0    -6 
  
*  ????   BEGIN 6600 IN-STACK LOOP
  
 PACK7.3  LX1    X1,B3       SHIFT CHARACTER FOR PACKING
          SB6    B6+B5       STRING LENGTH + 1
          SB3    A0+B3       PACKING SHIFT COUNT - 6
          BX6    X6+X1       PACK THE CHARACTER 
 PACK7.4  SB7    X4+7777B    BIAS ILLEGAL CHAR TO 7777B OR 10057B_10076B
          AX0    B7,X3       B7 IS TRANSFERRED TO SHIFT UNIT MODULO 64
          SX1    X4          STRIP EXPONENT FOR PACKING 
          ZR     X0,PACK7.5  IF ILLEGAL CHAR OR END-OF-LINE SENTINEL
          SA4    A4+1        GET NEXT CHARACTER 
 PACK7.H  LT     B7,B4,PACK7.3  IF NOT STRING TERMINATING CHARACTER 
  
*  ''''   END IN-STACK LOOP 
  
          SX7    A4-SBUFF 
          SB2    X1+         (B2) = STRING TERMINATING CHARACTER
          SA7    COLS        UPDATE POINTER TO NEXT COLUMN
          RJ     PVN         PROCESS VARIABLE NAME
          NZ     X6,PACK7.1  IF NAME LENGTH LEGAL 
          EQ     PACK7.2     (HERE ONLY IF C$ DEBUG STATEMENT ERROR)
  
 PACK7.5  SB2    X1          SAVE SPECIAL CHAR THAT TERMINATED STRING 
          RJ     PGCOM       GO CHECK CHAR AND LOOK FOR CONTINUATION
          SA0    -6 
          NZ     B4,PACK7.4  IF NOT STARTING DELIMITED HOLLERITH STRING 
          SA4    A4+1        ADVANCE COLUMN POINTER 
          EQ     PACK7.H
 PBC      SPACE  4,8
**        PBC - PROCESS BLANK AND COMMENT LINES.
* 
*         ENTRY  (X5) = .NZ. IF COMMENT LINE. 
* 
*         USES   X - 1, 2, 6, 7 
*                A - 1, 2, 6, 7 
*                B - NONE.
* 
*         CALLS  D.IDSP 
  
  
 PBC      SUBR               ** ENTRY/EXIT ** 
          NZ     X5,PBC2     IF COMMENT LINE
          SA1    NABC 
          SA2    CLABEL 
          SX6    1
          IX7    X1+X6
          SA7    A1          INCREMENT NON-ANSI BLANK LINE COUNT
          SA6    BLNKSTMT    BLANK STATEMENT (SO FAR) FLAG ON 
          BX7    X2 
          SA7    NLABEL      RETAIN LABEL OF LAST NON-BLANK STATEMENT 
 PBC2     SA1    DFLAG
          ZR     X1,EXIT.    IF DEBUG OFF 
          CALL   D.IDSP      SAVE UPDATE IDENT
          SB1    1
          EQ     EXIT.
 PGCOM    SPACE  4,8
**        PGCOM - COMMON ILLEGAL CHARACTER PROCESSOR. 
* 
* 
*                ENTERED IF AN ILLEGAL CHARACTER IS ENCOUNTERED 
*         IN *SBUFF*. 
  
  
 PGCOM1   RJ     SAV         SAVE PACKING REGISTERS 
          RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          NZ     X1,NEWS     IF NEW STATEMENT FOUND 
          RJ     RES         RESTORE PACKING REGISTERS
          SA4    SBUFF       GET FIRST CHARAC FROM NEW LINE 
          SB4    7777B+1R+   RESTORE TEST CONSTANT
  
 PGCOM    SUBR               ** ENTRY/EXIT ** 
          MI     X4,PGCOM1   IF E-O-L SENTINEL
          SB4    B2-1R" 
          NZ     B4,ERP6     IF NOT HOLLERITH STRING DELIM, ILLEGAL CHAR
          SB2    1R          CHANGE DELIM CHAR <"> (64B) TO < > (55B) TO
*                             CONSERVE SPACE IN THE 'STATE' JUMP TABLES.
*                             THIS AVOIDS ADDING 5 WORDS PER TABLE. 
          SX1    B2          FOR 'PACK7' AND 'PACK30', WHO SET B2=X1
          EQ     EXIT.       RETURN WITH B4=0 TO SIGNAL DELIM HOLL STRNG
 PLO      SPACE  4,8
 #NL      IFNE   #NL,0
**        PLO - PROCESS C/-LIST OPTIONS.
* 
* 
*         ENTRY  (CSSTMT) = 1S59 IF *LIST,ALL* OCCURRED 
*                         =  +1  IF *LIST,NONE* OCCURRED
*                         =  +0  IF C/-LIST DIRECTIVE DID NOT OCCUR 
*                (FTNCNT) = DPC LINE NUMBER FOR THIS STATEMENT
*                (NOLIST) = 1S59 IF IN *LIST,ALL* MODE
*                         =  +0  IF IN *LIST,NONE* MODE 
* 
*         EXIT
*                IF C/-LIST DIRECTIVE OCCURRED -- 
*                (CSSTMT)  = +0 
*                (C$STMT)  = .ZR. IF NEXT STATEMENT IS NOT C$-DEBUG 
*                          = .NZ. IF NEXT STATEMENT IS C$-DEBUG 
*                (SCNT)    = DPC LINE NUMBER FOR THIS STATEMENT 
* 
*                IF NEW C/-LIST DIRECTIVE .NE. CURRENT LISTING MODE --
*                (CP.FLIN) = DPC LINE NUMBER FOR THIS STATEMENT 
*                (NOLIST)  = SET TO NEW LISTING MODE
* 
*         USES   ALL
* 
*         CALLS  LSL,NXT,PLR,POSTER 
  
  
 PLO      SUBR   =           ** ENTRY/EXIT ** 
 PLO2     SA1    CSSTMT 
          SA2    NOLIST 
          SA3    FTNCNT 
          ZR     X1,EXIT.    IF C/-LIST DIRECTIVE DID NOT OCCUR 
          BX6    X3 
          AX1    59          (X1) = +0 IF C/-LIST,NONE IS NEW MODE
*                                 = -0 IF C/-LIST,ALL IS NEW MODE 
          BX7    X7-X7
          AX2    59          (X2) = +0 IF C/-LIST,NONE IS CURRENT MODE
*                                 = -0 IF C/-LIST,ALL IS CURRENT MODE 
          BX0    X1-X2       (X0) = +0 IF NEW MODE.EQ.CURRENT MODE
*                                 = -0 IF NEW MODE.NE.CURRENT MODE
          SA6    SCNT 
          SA7    A1          (CSSTMT) = +0
  
.T        IFNE   TEST,0 
          SA4    =XCO.SNAP
          LX4    1RU
          MI     X4,PLO4     IF (SNAP=U), IGNORE C/-LIST LINES
.T        ENDIF 
  
          MI     X0,PLO3     IF NEW MODE .NE. CURRENT MODE
  
*         HERE IF NEW MODE .EQ. CURRENT MODE. 
  
          RJ     PLR         PROCESS LISTING REQUEST (C/ LINE)
          EQ     PLO5 
  
 PLO3     SA6    =XCP.FLIN
          MI     X1,PLO4     IF NEW MODE IS *LIST,ALL*
  
*         HERE IF C/ LIST,NONE OCCURRED.
  
          RJ     DSL         DMP SAVED LINES (ONLY LISTS IF BEFORE HDR) 
          RJ     PLR         PROCESS LISTING REQUEST (C/-LIST,NONE LINE)
          MX6    0
          NO
          SA6    NOLIST      SET TO *LIST,NONE* STATUS
          EQ     PLO5 
  
*         HERE IF C/ LIST,ALL OCCURRED. 
  
 PLO4     MX6    1
          SA6    A2          SET TO *LIST,ALL* STATUS 
          RJ     PLR         PROCESS LISTING REQUEST (C/-LIST,ALL LINE) 
  
 PLO5     RJ     NXT         REQUEST AND PROCESS NEXT SOURCE LINE 
          SA3    C$STMT 
          SA2    CSSTMT 
          MX4    1
          BX6    X3*X4
          LX6    1           (X6) = +0 IF NEXT STATEMENT IS NOT C$-DEBUG
*                                 =  1 IF NEXT STATEMENT IS C$-DEBUG
          BX7    X7-X7
          SA6    A3 
          SA7    BLNKSTMT    CLEAR *BLANK STMT SO FAR* FLAG 
          NZ     X2,PLO2     IF C/ LINE FOLLOWED BY ANOTHER C/ LINE 
          NZ     X1,EXIT.    IF C/ LINE NOT FOLLOWED BY CONTINUATION
  
*         HERE IF C/-LIST DIRECTIVE FOLLOWED BY CONTINUATION LINE --
*           POST ERROR AND STRIP CONTINUATION LINES.
  
 PLO6     POSTER SEV=FE,NR=E319 
          RJ     NXT         STRIP CONTINUATION LINES 
          RJ     LSL         LIST SAVED LINES (C/ STMT IN ERR IF NOLIST)
          BX6    X6-X6
          MX7    60 
          SA6    =XFEFLAG    CLEAR *FATAL ERROR OCCURRED* FLAG
          SA7    TYPE        SET TO *UNTYPED* 
          SA6    BLNKSTMT    CLEAR *BLANK STMT SO FAR* FLAG 
          EQ     PLO2        CHECK NEW STATEMENT... 
 #NL      ELSE
 PLO      SUBR   =
          EQ     EXIT.
 #NL      ENDIF 
 PLR      SPACE  4,8
**        PLR - PROCESS LISTING REQUEST.
* 
*                PROCESSES A REQUEST TO LIST A SOURCE LINE. 
*         OPERATES IN ONE OF THREE MODES, AS FOLLOWS -- 
*         (1)  IF THE SOURCE LISTING OPTION IS OFF (L=0) OR A C/-NOLIST 
*         IS ACTIVE, SAVES EACH FULL STATEMENT (INITIAL LINE PLUS 
*         CONTINUATION LINES) IN A BUFFER FOR POSSIBLE ERROR LISTING. 
*         IN THIS MODE, COMMENT LINES ARE DISCARDED.
*         (2)  IF NOT IN MODE (1), BUT A VALID HEADER LINE HAS NOT BEEN 
*         FOUND, SAVES ALL LINES IN AN ATTEMPT TO LIST THE PROGRAM UNIT 
*         NAME AND TYPE IN THE HEADER OF THE FIRST PAGE.  IF THE BUFFER 
*         FILLS UP, LISTS ITS CONTENTS AND REVERTS TO NORMAL MODE (3).
*         (3)  IF NOT IN MODE (1) OR (2), LISTS EACH LINE IMMEDIATELY.
* 
* 
*         ENTRY  (CP.FLIN) ET SEQ = FORMATTED PRINT LINE IMAGE. 
*                (L.PLINE) = LINE LENGTH IN WORDS.
*                (IEF) = BEFORE/AFTER HEADER STATUS FLAG. 
*                (NOLIST) = C/-LIST-NOLIST FLAG.
*                (NXCOMENT) = .MI. IF COMMENT LINE, ELSE .PL. 
*                (SLIST) = SOURCE LISTING OPTION FLAG.
* 
*         EXIT   LINE LISTED OR SAVED.
*                (L.PLINE) = 0
*                (B1) = 1 
*                (B5) = 1 
* 
*         USES   X - 1, 2, 3, 4, 6, 7 
*                A - 1, 2, 3, 4, 6, 7 
*                B - 1, 5, 7
* 
*         CALLS  LISTL, LSL, MOVE 
  
  
 PLR      SUBR               ** ENTRY/EXIT ** 
 PLR2     SA1    L.PLINE
          SA2    =XSLIST
          SA3    =XNOLIST 
          SA4    IEF
          SB1    1
          BX6    X2*X3
          SB5    B1 
          ZR     X1,EXIT.    IF LINE ALREADY PROCESSED
          ZR     X6,PLR3     IF (L=0) OR C/-NOLIST ACTIVE 
          NZ     X4,PLR4     IF BEFORE HEADER LINE
  
*         LIST LINE IMMEDIATELY.
  
          LISTL  =XCP.FLIN,X1 
          MX6    0
          SA6    L.SL 
          EQ     PLR6 
  
*         PROCESS SOURCE LISTING OFF (L=0) OR C/-NOLIST ON. 
  
 PLR3     SA1    NXCOMENT 
          SA2    BLNKSTMT 
          SA3    CONTCNT
          SA4    FTNCNT 
          MI     X1,PLR6     IF COMMENT, IGNORE 
          NZ     X2,PLR6     IF BLANK, IGNORE 
          NZ     X3,PLR4     IF CONTINUATION LINE 
          MX6    0
          BX7    X4 
          SA6    L.SL        ERASE OLD SAVED LINES BY CLEARING LENGTH 
          SA7    =XCP.FLIN   SAVE INITIAL LINE NUMBER (MAY NOT BE *5) 
  
*         SAVE NEW LINE FOR (POSSIBLE) DEFERRED LISTING.
  
 PLR4     SA1    L.PLINE     (X1) = NEW LINE LENGTH 
          SA3    L.SL        (X3) = TOTAL LENGTH OF OLD SAVED LINES 
          IX6    X3+X1
          SB7    X6-DLBUFL
          LE     B7,B0,PLR5  IF BUFFER HAS ROOM FOR NEW LINE
          RJ     LSL         LIST SAVED LINES (DUMP FULL BUFFER)
          EQ     PLR2        LOOP TO RECHECK *IEF*
  
 PLR5     SA6    A3          UPDATE SAVED LINE(S) LENGTH
          MOVE   X1,=XCP.FLIN,DLBUF+X3
 PLR6     MX6    0
          SB5    B1 
          SA6    L.PLINE     MARK NEW LINE *PROCESSED*
          EQ     EXIT.
 POINT    TITLE  PROCESS STRING AFTER A PERIOD <.>
* CHECKS FOR CONSTANT OR A RELATIONAL OR LOGICAL OPERATOR AND MAKES 
*  APPROPRIATE E-LIST AND CONSTOR ENTRIES.
  
 POINT    SX7    *           TURN ON HANGING . FLAG 
          SA7    HANG.
          RJ     GET         RETURNS (B2) = NEXT CHARACTER
          SX7    0
          SA7    HANG.       HANGING . FLAG OFF 
 POINTT   SB3    1R+
          GE     B2,B3,CERP  IF NEXT CHARACTER NOT ALPHA OR DIGIT 
          SB3    1R0
          GE     B2,B3,PCON  IF BEGINNING A CONSTANT STRING 
          SX7    3RREL
          SA7    EXPEXP      HANGING EXPONENT FLAG ON 
          SA7    RELFLAG     RELATIONAL OPR PACK FLAG ON
          RJ     PACK7
          SA1    ELAST
          SB3    1R.
          SX7    X1+1 
          SA2    X1          (X2) = CHAR STRING AFTER POINT 
          SA7    A1          BACK UP ELIST POINTER
          BX6    X2          SAVE STRING FOR POSSIBLE *ERPRO* CALL
          NE     B2,B3,ERP5  IF NO POINT AFTER STRING 
          SB3    5
          LX2    12          LEFT JUSTIFY STRING
          GT     B6,B3,ERP5  IF STRING TOO LONG FOR RELATIONAL OPERATOR 
          NE     B6,B3,POINT1      IF NOT 5-CHARACTER STRING
          SA3    TYPE 
          SX0    X3-DBGFSTT 
          MI     X0,POINT1   IF NOT A DEBUG STATEMENT 
          SB6    B6+1        CHAR COUNT + 1 FOR SPECIAL DEBUG SEARCH
 POINT1   SA3    PTBL1-1+B6  (X3) = TABLE 2 CONTROL WORD
          MX4    6*6         LIMITS PICTURE MATCHING TO 6 CHARACTERS
          SA1    X3          GET FIRST PICTURE
          SB3    X3          B3 = PICTURE POINTER 
          LX3    30 
          SB7    X3          SEARCH STOP ADDRESS
          NE     B6,B5,POINT2      IF NOT 1-CHARACTER OPERATOR
          MX4    1*6         LIMIT PICTURE MATCHING TO 1 CHARACTER
 POINT2   BX3    X2-X1       STRING - PICTURE 
          BX0    X4*X3
          ZR     X0,POINT3   IF STRING MATCHED PICTURE
          SB3    B3+B5       PICTURE POINTER + 1
          SA1    B3 
          LT     B3,B7,POINT2  IF SEARCH TABLE NOT EXHAUSTED
          EQ     ERP4        NOT A RELATIONAL OPERATOR
  
 POINT3   SX6    0
          SA6    EXPEXP      TURN OFF RELATIONAL FLAG 
          NE     B6,B5,ADD1  IF NOT 1-CHARACTER STRING
          BX3    X1          'SCNSAVE' WILL PRESERVE X3 
          SX0    -E196       ERR MSG NR - *NON-ANSI LOGICAL OPR*
          RJ     ANSIERP
          BX1    X3          RESTORE X1 
          EQ     ADD1        GO MAKE E-LIST ENTRY 
 PVN      SPACE  4,8
**        PVN - PROCESS VARIABLE NAME.
* 
*                TASKS PERFORMED -- 
*         1.  SUFFIXES NAMES THAT DUPLICATE HARDWARE REGISTERS (A0-A7,
*             B0-B7, X0-X7) WITH A $ FOR UNIQUENESS.  THIS IS NECESSARY 
*             FOR POSSIBLE *COMPASS* OBJECT CODE ASSEMBLY.
*         2.  BLANK FILLS NAME. 
*         3.  PREFIXES NAME WITH E-LIST TYPE CODE FOR *VARIABLE*(2001B).
*         4.  IF 7-CHARACTER NAME, POSTS NON-ANSI DIAGNOSTIC. 
*         5.  IF .GT. 7-CHAR NAME, PROCESSES ERROR CONDITION. 
* 
* 
*         ENTRY  (X6) = NAME, LEFT ADJUSTED TO BIT 47.
*                (B6) = NAME LENGTH (CHARACTERS). 
* 
*         EXITS  NORMAL --
*                (X6) = 12/2001B, 48/NAME FORMATTED AS ABOVE. 
*                (B5) = 1 
*                (B6) = NAME LENGTH (CHARACTERS), ADJUSTED FOR $ IF ANY.
*                ABNORMAL (NAME LONGER THAN 7 CHARACTERS) --
*                IF C$ DEBUG LINE, RETURNS TO CALLER WITH (X6) = 0. 
*                IF OTHER LINE, EXITS TO *ERP5*.
* 
*         USES   X - 2, 3, 4, 6, 7
*                A - 2
*                B - 5, 6, 7
* 
*         CALLS  ANSIERP
  
  
 PVN      SUBR               ** ENTRY/EXIT ** 
          SB5    1
          BX7    X6 
          SB7    B5+B5
  
*         SUFFIX WITH $ IF HARDWARE REGISTER NAME.
  
          NE     B6,B7,PVN2  IF NOT 2-CHARACTER NAME
          SA2    PVNA        SHIFT TEST MASK FOR *ABX*
          MX4    -1*6 
          LX7    -7*6 
          BX3    -X4*X7      EXTRACT 1ST CHARACTER
          SB7    X3 
          LX2    B7 
          PL     X2,PVN2     IF 1ST CHARACTER NOT A, B OR X 
          LX7    1*6
          MX2    1R7-1R0+1   FORM SHIFT TEST MASK FOR *01234567*
          BX3    -X4*X7      EXTRACT 2ND CHARACTER
          SX4    1R$
          LX2    -1R0 
          SB7    X3 
          LX4    5*6
          LX2    B7 
          PL     X2,PVN2     IF 2ND CHARACTER NOT 0-7 
          BX6    X6+X4       APPEND $ 
          SB6    B6+B5       (B6) = STRING LENGTH + 1 
  
*         PREFIX WITH E-LIST TYPE CODE AND BLANK FILL.
  
 PVN2     SB7    7
          SA2    FILL8R+B6
          GT     B6,B7,PVN3  IF NAME TOO LONG 
          PX7    X6,B5       PREFIX E-LIST TYPE CODE (2001B)
          BX6    X7+X2       BLANK FILL 
          NE     B6,B7,EXIT. IF NOT 7-CHARACTER NAME
          BX4    X6 
          SX0    E34         ERR MSG NR - *7-CHAR NAME IS NON-ANSI* 
          RJ     ANSIERP     POST NON-ANSI ERROR MESSAGE
          SB5    1
          EQ     EXIT.
  
*         ERROR PROCESSING - NAME LONGER THAN 7 CHARACTERS. 
  
 PVN3     SA2    DTYPE
          ZR     X2,ERP5     IF NOT DEBUG STATEMENT 
          SX6    0
          SA6    TYPE        SET *BAD DEBUG* STATEMENT
          EQ     EXIT.
  
  
  
 PVNA     BSS    0           SHIFT TEST MASK FOR *ABX*
          ECHO   2,BIT=(A,B,X)
          POS    60-1R_BIT
          VFD    1/1
          POS    0
 P$T      SPACE  4,8
**        P$T - PROCESS $ TERMINATOR. 
* 
*                TASKS PERFORMED -- 
*         1.  MAKE THE (CLABEL) = (NLABEL) TRANSFER.
*         2.  POST NON-ANSI ERROR MESSAGE FOR $ TERMINATOR. 
* 
*         ENTRY  (NLABEL) = IF THIS STATEMENT CONTAINS A LEGAL, 
*                           NON-EMPTY LABEL, CONTAINS IT IN DPC,
*                           LEFT JUSTIFIED WITH BLANK FILL. 
*                           OTHERWISE, .EQ. 0.
* 
*         EXIT   (CLABEL) = OLD (NLABEL)
*                (NLABEL) = 0 
*                (SBUFLG) = -1, $ TERMINATOR FLAG ON. 
* 
*         USES   A - 2,6,7
*                X - 2,6,7
*                B - 6,7
* 
*         CALLS  ANSIERP     SAVES AND RESTORES X - 3,5,6 
*                                               B - 1,2,3,6 
  
 P$T      SUBR               ** ENTRY/EXIT ** 
          SA2    NLABEL 
          BX6    X6-X6
          MX7    -1 
          SA6    A2 
          SA7    SBUFLG 
          BX6    X2 
          SA6    CLABEL 
          POSTERR  SEV=ANSI,NR=E210,RETURN=EXIT.
 RES      SPACE  4,8
**        RES - RESTORE CRITICAL PACKING REGISTERS. 
* 
* 
*         RESTORES  X - 3,5,6 
*                   A - NONE
*                   B - 1,2,3,6 
* 
*         USES   X - 3,5,6
*                A - 3,5
*                B - 1,2,3,6
* 
*         CALLS  NONE 
  
  
 RES      SUBR               ** ENTRY/EXIT ** 
          SA3    REG=B1 
          SA5    REG=B2 
          SB1    X3 
          SB2    X5 
          SA3    REG=B3 
          SA5    REG=B6 
          SB3    X3 
          SB6    X5 
          SA3    REG=X6 
          SA5    REG=X5 
          BX6    X3 
          SA3    REG=X3 
          EQ     EXIT.
*CALL COMFRNC 
 SAV      SPACE  4,8
**        SAV - SAVE CRITICAL PACKING REGISTERS.
* 
* 
*         SAVES     X - 3,5,6 
*                   A - NONE
*                   B - 1,2,3,6 
* 
*         USES   X - 6,7
*                A - 6,7
*                B - NONE 
* 
*         CALLS  NONE 
  
  
 SAV      SUBR               ** ENTRY/EXIT ** 
          SA6    REG=X6 
          BX7    X3 
          LX6    X5 
          SA7    REG=X3 
          SA6    REG=X5 
          SX7    B1 
          SX6    B2 
          SA7    REG=B1 
          SA6    REG=B2 
          SX7    B3 
          SX6    B6 
          SA7    REG=B3 
          SA6    REG=B6 
          EQ     EXIT.
 SLO      SPACE  4,8
 #NL      IFNE   #NL,0
**        SLO - SET LIST OPTION FLAGS.
* 
* 
*         ENTRY  (NOLIST) = 1S59 IF IN *LIST,ALL* MODE
*                         =  +0  IF IN *LIST,NONE* MODE 
*                (X6)     =  +0 
* 
*         EXIT   (ANSI)   =  +0 
*                (IEFLG)  =  +0 
*                (LOP=O)  =  +0 
*                (LOP=R)  =  +0 
*                (R=FLAG) =  +0 
* 
*         USES   X - 1,7
*                A - 1,6,7
*                B - NONE 
* 
*         CALLS  NONE 
  
  
 SLO      SUBR               ** ENTRY/EXIT ** 
          SA1    NOLIST 
          MI     X1,EXIT.    IF IN *LIST,ALL* MODE AT END LINE TIME 
  
*         HERE IF IN *LIST,NONE* MODE AT END LINE TIME. 
  
          SA6    =XANSI      SET TO *DO NOT LIST ANSI ERRORS* 
          SA6    =XIEFLG     SET TO *DO NOT LIST INFORMATIVE ERRORS*
          SA6    =XLOP=O     SET TO *DO NOT GENERATE OBJECT LIST* 
          SA6    =XLOP=R     SET TO *DO NOT LIST REFMAP*
          SA6    =XR=FLAG    SET TO *R=0* 
          EQ     EXIT.
 #NL      ELSE
 SLO      SUBR
          EQ     EXIT.
 #NL      ENDIF 
 SRCH     TITLE  SRCH - SEARCH FOR MATCH OF LEADING KEYWORD.
**        SRCH - SEARCH INITIAL STRING FOR MATCH OF LEADING KEYWORD.
* 
*         ENTRY  (KEYL) = 12/2000B+CHARCNT,48/WORD COUNT
*                (KEYW) = KEYWORD, LEFT JUSTIFIED, ZERO FILL. 
*         EXIT   (B1) = NEXT *STATE* JUMP ADDRESS.
*                (B2) = CHARACTER THAT TERMINATED ALPHANUMERIC STRING.
*                (B3) = NR OF CHARS REMAINING IN FIXED KEYWORD BUFFER.
*                (B4) = STATEMENT TYPE CODE.
*                (B5) = 1 
*                (A7),(X7) = ADDR AND CONTENTS OF *KEYL* AFTER REMOVING 
*                            KEYWORD FROM STRING. 
* 
*         USES - ALL REGISTERS
  
  
 SRCH     SUBR               ** ENTRY/EXIT ** 
  
*         INITIALIZATION. 
  
          SA1    KEYW        GET FIRST CHAR OF SET SEARCH LIMITS
          MX0    6
          BX2    X0*X1
          LX2    6
          SA3    SRCHA-1+X2 
          SB7    X3          (B7) = LIMIT 
          AX3    30 
          SB6    X3          (B6) = INDEX 
          SB5    1
          MX7    60 
          SA0    B2          SAVE B2
          SA7    ATYPE
          ZR     B6,ERP2     IF NO KEYWORD BEGINS WITH FIRST LETTER 
  
*         MAIN SEARCH LOOP. 
  
  
 SRCH1    SA1    KEYL 
          MX7    1
          SA2    A1+B5       (X2) = FIRST WORD OF INITIAL CHAR STRING 
          UX1    B3,X1       (B3) = CHARS IN INITIAL STRING 
  
*         SEARCH FOR MATCH OF KEYWORD 
  
 SRCH2    SA3    B6          KEYWORD DESCRIPTOR 
          UX0    B4,X3
          SA4    X3          KEYWORD CHAR STRING
          AX5    B4,X7       (X5)=MASK(LEN OF KEYWORD)
          SB2    60 
          LT     B4,B2,SRCH3 IF LEN OF KEYWORD .LT. 10
          MX5    60 
 SRCH3    SB6    B6+B5
          BX6    X5*X2       EXTRACT KEYWORD FROM (KEYW)
          GT     B6,B7,ERP2  IF END OF THE TABLE
          BX4    X4-X6       PICTURE-STRING 
          NZ     X4,SRCH2    IF NO MATCH
          SB2    -B5
          SX6    B4-54
          MI     X6,SRCH4    IF LEN(KEYWD) @ 9 CHARS
          SB4    B4-60
          MI     B4,SRCH4    IF LEN(KEYWD) = 10 CHARS 
  
*         HERE IF KEYWORD .GT. 10 CHARACTERS
  
          SB2    -2          WORD INDEX = 2 
          SA3    A2+B5
          AX5    B4,X7
          SA4    A4+1 
          BX3    X5*X3
          IX6    X4-X3
          NZ     X6,SRCH2    IF NO MATCH OF REST OF KEYWORD 
          SB3    B3-10       REDUCE CHAR COUNT
  
*         EXTRACT *TYPE* AND *ATYPE* FROM *KEYW* TABLE. 
  
 SRCH4    SA3    =40404040404040404040B 
          AX0    18 
          MX4    -8 
          BX6    -X4*X0      EXTRACT STMT TYPE CODE 
          AX0    8
          MX4    -4 
          BX7    X4+X0
          ZR     X7,SRCH5    IF *ATYPE* NOT TO BE SET 
          BX7    -X4*X0 
          SA7    ATYPE
  
*         REMOVE KEYWORD FROM LEADING STRING. 
  
 SRCH5    SA6    TYPE 
          BX3    X3*X5
          SA2    A1-B2       (X2)=1ST WORD TO BE MOVED
          AX0    4
          SB7    X0          (B7) = SUCCESS EXIT
          CX3    X3 
          SB6    X3 
          SB3    B3-B6       (B3)=(KEYW) CHAR CNT WITHOUT KEYWORD 
          SA7    A1          PRESTORE 
          SB4    B4+B5
          SB2    X1+B2
  
*         LEFT JUSTIFY REST OF CHARACTER STRING IN (KEYW).
  
 SRCH6    BX3    -X5*X2 
          SA2    A2+B5
          BX4    X5*X2
          SB2    B2-B5
          IX0    X4+X3
          LX7    B4,X0
          SA7    A7+1 
          PL     B2,SRCH6    IF NOT DONE
  
*         SET UP EXIT CONDITIONS AND JUMP...
  
          SB4    A1          ADJUST *KEYL*
          SX2    A7-B4
          SB2    A0          (B2)=CHAR THAT TERMINATED ALPHANUMERIC STR 
          PX7    B3,X2
          SB4    X6          (B4)=STMT TYPE CODE
          SA7    A1 
          JP     B7          SUCCESS EXIT...
  
*         *TYPE*  - CONTINUE SEARCH 
  
 SRCH7    SB6    KW.TY
          SB7    KW.TYI 
          MX6    1
          NO
          SA6    NAFLG       SET *NON-ANSI TYPE DECL OCCURRED* FLAG 
          EQ     SRCH1
  
*         MODE DECLARATION - *LOGICAL*, *INTEGER*,... 
  
 SRCH8    SB6    7
          LE     B3,B6,EXIT. IF CHAR COUNT .LE. 7, SUCCESS
          SB6    KW.FN       CHECK FOR *FUNCTION* ONLY
          SB7    B6+1 
          EQ     SRCH1
  
*         IMPLICIT - GO BACK FOR FIRST TYPE 
  
 SRCH9    SB6    KW.TYI 
          SB7    KW.TYIL
          EQ     SRCH1
  
*         PROCESS KEYWORD *DOUBLE* SO THAT *SCAN22* CAN DIAGNOSE AS 
*         NON-ANSI. 
  
 SRCH11   MX6    1
          NO
          SA6    NAFLG       SET *NON-ANSI TYPE DECL OCCURRED* FLAG 
          EQ     SRCH8       REJOIN NORMAL FLOW...
  
*         PROCESS KEYWORD *END*.
  
 SRCH12   PL     B2,SRCH13   IF NOT NORMAL EOS
          ZR     B3,ENDP     IF NO EXTRANEOUS CHARACTERS
          EQ     ERP2 
  
 SRCH13   SA4    SBUFF+3
          SA2    =7R
          SX4    X4 
          LX2    CHAR 
          BX4    X4+X2
          POSTER SEV=INF,NR=E325,FMT=DPC,TXT=X4,RETURN=ENDP 
          EQ     ERP2 
 KEYW     TITLE  FORTRAN STATEMENT KEYWORD TABLE. 
**        FORTRAN STATEMENT KEYWORD TABLE 
* 
*         KEYWORDS ARE ORDERED IN THE TABLE BY THEIR FIRST LETTERS. 
*         WITHIN A FIRST LETTER GROUP, KEYWORDS SUCH AS *DOUBLE*, 
*         WHICH ARE SUBSTRINGS OF OTHER KEYWORDS, MUST COME AFTER THE 
*         STRINGS INCLUDING THEM. 
  
          KEYW   ASSIGN,14,,(25)
          KEYW   BUFFERIN,27,,(46)
          KEYW   BUFFEROUT,28,,(46) 
          KEYW   BACKSPACE,32,,(25) 
          KEYW   BLOCKDATA,0,0,(25) 
          KEYW   CALL,19,,(25,27,47,49) 
          KEYW   CONTINUE,21,,(25)
          KEYW   COMMON,4,,(23,25,27,45,47,49)
 8        KEYW   COMPLEX,8,4,(25,27,47,49)
          KEYW   DATA,10,,(23,27,45,47,49)
          KEYW   DIMENSION,5,,(47,49) 
          KEYW   DECODE,30,,(42,46,47)
 8        KEYW   DOUBLEPRECISION,8,3,(25,27,47,49)
 11       KEYW   DOUBLE,8,3,(25,27,47,49) 
          KEYW   DO,24,,(63)
          KEYW   ENCODE,29,,(42,44,46,47,410) 
          KEYW   ENDFILE,33,,(25) 
          KEYW   EXTERNAL,6,,(25,27)
          KEYW   EQUIVALENCE,7,,(47,49) 
          KEYW   ENTRY,36,,(25) 
 12       KEYW   END,13,,(25) 
 8        KEYW   ECS,8,5,(25,27,47,49)
 KW.FN    BSS    0
          KEYW   FUNCTION,1,,(47) 
          KEYW   GOTO,15,,(25,27,42,44,46,47,49)
          KEYW   IF,17,,(42)
 8        KEYW   INTEGER,8,1,(25,27,47,49)
 9        KEYW   IMPLICIT,3,,(47,49),NA 
 8        KEYW   LOGICAL,8,0,(25,27,47,49)
          KEYW   LEVEL,2,,(27)
          KEYW   NAMELIST,11,,(23)
          KEYW   OVERLAY,0,3,(47) 
          KEYW   PRINT,34,,(22,25,27,42,44,410,46,47,49)
          KEYW   PUNCH,35,,(22,25,27,42,44,410,46,47,49)
          KEYW   PAUSE,23,,(25) 
          KEYW   PROGRAM,0,2,(25,47)
          KEYW   READ,25,,(22,25,27,42,410,46,47,49)
          KEYW   REWIND,31,,(25)
          KEYW   RETURN,20,,(25)
 8        KEYW   REAL,8,2,(25,27,49)
          KEYW   STOP,22,,(25)
          KEYW   SUBROUTINE,0,1,(25,27,47,49) 
 7        KEYW   TYPE,8,,(25,27,47,49)
          KEYW   WRITE,26,,(22,25,27,42,44,410,46,47,49)
          AUXT   0           TERMINATE AUX SEARCH TABLE 
 AUXT     OPSYN  NIL
          LIST   -G 
  
 KW.TY    BSS    0
          ECHO   1,T=(LOGICAL,INTEGER,REAL,DOUBLEPRECISION,DOUBLE,COMPLE
,X,ECS),V=(0,1,2,3,3,4,5) 
          KEYW   T,8,V
  
 KW.TYI   BSS    0
          ECHO   1,T=(LOGICAL,INTEGER,REAL,DOUBLEPRECISION),V=(0,1,2,3) 
          KEYW   T,3,V
          KEYW   DOUBLE,3,3 
          KEYW   COMPLEX,3,4
          KEYW   ECS,3,5
 KW.TYIL  CON    0           SEARCH TERMINATOR
  
  
          ECHO   3,NR=(22,23,25,27,42,44,410,45,46,47,49,63)
          USE    CLR_NR 
          POS    0
          USE    *
  
          USE    NANSI
          POS    0
          USE    *
          SPACE  4,8
          LIST   D
          END 
